ghc-lib 8.10.1.20200916 → 8.10.2.20200808
raw patch · 44 files changed
+2146/−1159 lines, 44 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +33/−9
- compiler/GHC/StgToCmm/Foreign.hs +29/−0
- compiler/GHC/StgToCmm/Prof.hs +1/−1
- compiler/GHC/StgToCmm/Ticky.hs +7/−8
- compiler/GHC/StgToCmm/Utils.hs +10/−7
- compiler/cmm/CLabel.hs +95/−63
- compiler/cmm/Cmm.hs +28/−12
- compiler/cmm/CmmCallConv.hs +13/−8
- compiler/cmm/CmmMachOp.hs +3/−0
- compiler/cmm/CmmParse.y +5/−3
- compiler/cmm/PprC.hs +5/−0
- compiler/coreSyn/CorePrep.hs +4/−2
- compiler/deSugar/Coverage.hs +10/−6
- compiler/deSugar/DsBinds.hs +3/−4
- compiler/deSugar/DsExpr.hs +63/−24
- compiler/ghci/Linker.hs +15/−3
- compiler/llvmGen/LlvmCodeGen/Base.hs +99/−13
- compiler/llvmGen/LlvmCodeGen/CodeGen.hs +24/−16
- compiler/llvmGen/LlvmCodeGen/Data.hs +2/−1
- compiler/main/DriverPipeline.hs +28/−33
- compiler/main/SysTools/Settings.hs +4/−0
- compiler/main/SysTools/Tasks.hs +15/−0
- compiler/nativeGen/X86/CodeGen.hs +91/−8
- compiler/prelude/PrelInfo.hs +8/−4
- compiler/rename/RnNames.hs +9/−8
- compiler/simplCore/SimplUtils.hs +19/−0
- compiler/specialise/Specialise.hs +542/−378
- compiler/typecheck/TcCanonical.hs +8/−4
- compiler/typecheck/TcClassDcl.hs +2/−1
- compiler/typecheck/TcErrors.hs +1/−2
- compiler/typecheck/TcExpr.hs +19/−21
- compiler/typecheck/TcHsSyn.hs +16/−34
- compiler/typecheck/TcHsType.hs +238/−116
- compiler/typecheck/TcInstDcls.hs +59/−8
- compiler/typecheck/TcMType.hs +50/−43
- compiler/typecheck/TcSMonad.hs +63/−79
- compiler/typecheck/TcSigs.hs +2/−5
- compiler/typecheck/TcSplice.hs +2/−2
- compiler/typecheck/TcTyClsDecls.hs +503/−212
- compiler/typecheck/TcUnify.hs +7/−11
- ghc-lib.cabal +3/−4
- ghc-lib/stage0/lib/DerivedConstants.h +5/−5
- ghc-lib/stage0/lib/ghcversion.h +1/−1
- ghc-lib/stage0/lib/settings +2/−0
compiler/GHC/HsToCore/PmCheck/Oracle.hs view
@@ -1236,10 +1236,11 @@ 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- = defaultRecTcMaxBound+ = 3 rec_ts' = setRecTcMaxBound rec_max_bound rec_ts allM (nonVoid rec_ts' amb_cs) tys_to_check @@ -1259,6 +1260,7 @@ 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@@ -1307,7 +1309,7 @@ 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: @@ -1337,6 +1339,7 @@ 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@@ -1362,15 +1365,20 @@ `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]. -* Performance considerations+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. -We must be careful when recursively calling `nonVoid` on the strict argument-types of an InhabitationCandidate, because doing so naïvely can cause GHC to-fall into an infinite loop. Consider the following example:+Consider the following example: data Abyss = MkAbyss !Abyss- stareIntoTheAbyss :: Abyss -> a stareIntoTheAbyss x = case x of {} @@ -1391,7 +1399,6 @@ newtypes, like in the following code: newtype Chasm = MkChasm Chasm- gazeIntoTheChasm :: Chasm -> a gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive @@ -1415,9 +1422,26 @@ 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 = ![a] !T+ 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
compiler/GHC/StgToCmm/Foreign.hs view
@@ -13,6 +13,8 @@ emitSaveThreadState, saveThreadState, emitLoadThreadState,+ emitSaveRegs,+ emitRestoreRegs, loadThreadState, emitOpenNursery, emitCloseNursery,@@ -31,6 +33,7 @@ import BlockId (newBlockId) import Cmm import CmmUtils+import CmmCallConv import MkGraph import Type import RepType@@ -303,6 +306,32 @@ mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr else mkNop ]++++-- | Save STG registers+--+-- STG registers must be saved around a C call, just in case the STG+-- register is mapped to a caller-saves machine register. Normally we+-- don't need to worry about this the code generator has already+-- loaded any live STG registers into variables for us, but in+-- hand-written low-level Cmm code where we don't know which registers+-- 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)+ 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+ emitCloseNursery :: FCode () emitCloseNursery = do
compiler/GHC/StgToCmm/Prof.hs view
@@ -350,7 +350,7 @@ loadEra :: DynFlags -> CmmExpr loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))- [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+ [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr
compiler/GHC/StgToCmm/Ticky.hs view
@@ -118,7 +118,6 @@ import CLabel import SMRep -import Module import Name import Id import BasicTypes@@ -366,7 +365,7 @@ , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) (mkIntExpr dflags 1) ]- ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+ ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()@@ -506,12 +505,12 @@ bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (bWord dflags)- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop else addToMemLbl (bWord dflags)- (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+ (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr")) 1 ]} @@ -575,13 +574,13 @@ ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code bumpTickyCounter :: FastString -> FCode ()-bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl) bumpTickyCounterBy :: FastString -> Int -> FCode ()-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl) bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)+bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do@@ -622,7 +621,7 @@ emit (addToMem (bWord dflags) (cmmIndexExpr dflags (wordWidth dflags)- (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+ (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl))) (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags)))) 1)
compiler/GHC/StgToCmm/Utils.hs view
@@ -22,6 +22,7 @@ tagToClosure, mkTaggedObjectLoad, callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,+ callerSaveGlobalReg, callerRestoreGlobalReg, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,@@ -247,8 +248,8 @@ where platform = targetPlatform dflags - caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)- caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)+ caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save)+ caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery {- ,SparkHd,SparkTl,SparkBase,SparkLim -}@@ -256,12 +257,14 @@ regs_to_save = filter (callerSaves platform) system_regs - callerSaveGlobalReg reg- = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))+callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph+callerSaveGlobalReg dflags reg+ = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) - callerRestoreGlobalReg reg- = mkAssign (CmmGlobal reg)- (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))+callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph+callerRestoreGlobalReg dflags reg+ = mkAssign (CmmGlobal reg)+ (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) -------------------------------------------------------------------------
compiler/cmm/CLabel.hs view
@@ -10,6 +10,7 @@ module CLabel ( CLabel, -- abstract type+ NeedExternDecl (..), ForeignLabelSource(..), pprDebugCLabel, @@ -69,6 +70,7 @@ mkCmmRetLabel, mkCmmCodeLabel, mkCmmDataLabel,+ mkRtsCmmDataLabel, mkCmmClosureLabel, mkRtsApFastLabel,@@ -179,13 +181,14 @@ IdLabel Name CafInfo- IdLabelInfo -- encodes the suffix of the label+ IdLabelInfo -- ^ encodes the suffix of the label -- | A label from a .cmm file that is not associated with a .hs level Id. | CmmLabel- UnitId -- what package the label belongs to.- FastString -- identifier giving the prefix of the label- CmmLabelInfo -- encodes the suffix of the label+ UnitId -- ^ what package the label belongs to.+ NeedExternDecl -- ^ does the label need an "extern .." declaration+ FastString -- ^ identifier giving the prefix of the label+ CmmLabelInfo -- ^ encodes the suffix of the label -- | A label with a baked-in \/ algorithmically generated name that definitely -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so@@ -205,13 +208,13 @@ -- | A 'C' (or otherwise foreign) label. -- | ForeignLabel- FastString -- name of the imported label.+ FastString -- ^ name of the imported label. - (Maybe Int) -- possible '@n' suffix for stdcall functions+ (Maybe Int) -- ^ possible '@n' suffix for stdcall functions -- When generating C, the '@n' suffix is omitted, but when -- generating assembler we must add it to the label. - ForeignLabelSource -- what package the foreign label is in.+ ForeignLabelSource -- ^ what package the foreign label is in. FunctionOrData @@ -224,7 +227,7 @@ -- Must not occur outside of the NCG or LLVM code generators. | AsmTempDerivedLabel CLabel- FastString -- suffix+ FastString -- ^ suffix | StringLitLabel {-# UNPACK #-} !Unique@@ -262,6 +265,24 @@ deriving Eq +-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the+-- label (e.g. "extern StgWordArray(foo)"). The type is fixed to StgWordArray.+--+-- Symbols from the RTS don't need "extern" declarations because they are+-- exposed via "includes/Stg.h" with the appropriate type. See 'needsCDecl'.+--+-- The fixed StgWordArray type led to "conflicting types" issues with user+-- provided Cmm files (not in the RTS) that declare data of another type (#15467+-- and test for #17920). Hence the Cmm parser considers that labels in data+-- sections don't need the "extern" declaration (just add one explicitly if you+-- need it).+--+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes+-- for why extern declaration are needed at all.+newtype NeedExternDecl+ = NeedExternDecl Bool+ deriving (Ord,Eq)+ -- This is laborious, but necessary. We can't derive Ord because -- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the -- implementation. See Note [No Ord for Unique]@@ -272,10 +293,11 @@ compare a1 a2 `thenCmp` compare b1 b2 `thenCmp` compare c1 c2- compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =+ compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = compare a1 a2 `thenCmp` compare b1 b2 `thenCmp`- compare c1 c2+ compare 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) =@@ -367,7 +389,7 @@ = case lbl of IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel" <> whenPprDebug (text ":" <> text (show info)))- CmmLabel pkg _name _info+ CmmLabel pkg _ext _name _info -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg) RtsLabel{} -> ppr lbl <> (parens $ text "RtsLabel")@@ -498,24 +520,24 @@ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel- = CmmLabel rtsUnitId (fsLit "nonmoving_write_barrier_enabled") CmmData-mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo-mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo-mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo-mkMainCapabilityLabel = CmmLabel rtsUnitId (fsLit "MainCapability") CmmData-mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo-mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo-mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo-mkTopTickyCtrLabel = CmmLabel rtsUnitId (fsLit "top_ct") CmmData-mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmInfo-mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS") CmmInfo-mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo-mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo-mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo-mkBadAlignmentLabel = CmmLabel rtsUnitId (fsLit "stg_badAlignment") CmmEntry+ = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData+mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo+mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo+mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo+mkMainCapabilityLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability") CmmData+mkMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo+mkTopTickyCtrLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct") CmmData+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE") CmmInfo+mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS") CmmInfo+mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo+mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry mkSRTInfoLabel :: Int -> CLabel-mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo+mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo where lbl = case n of@@ -539,17 +561,24 @@ ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,- mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel+ mkCmmCodeLabel, mkCmmClosureLabel :: UnitId -> FastString -> CLabel -mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo-mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry-mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo-mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet-mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode-mkCmmDataLabel pkg str = CmmLabel pkg str CmmData-mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure+mkCmmDataLabel :: UnitId -> NeedExternDecl -> FastString -> CLabel+mkRtsCmmDataLabel :: FastString -> CLabel +mkCmmInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmInfo+mkCmmEntryLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmEntry+mkCmmRetInfoLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo+mkCmmRetLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmRet+mkCmmCodeLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmCode+mkCmmClosureLabel pkg str = CmmLabel pkg (NeedExternDecl True) str CmmClosure+mkCmmDataLabel pkg ext str = CmmLabel pkg ext str CmmData+mkRtsCmmDataLabel str = CmmLabel rtsUnitId (NeedExternDecl False) str CmmData+ -- RTS symbols don't need "GHC.CmmToC" to+ -- generate \"extern\" declaration (they are+ -- exposed via includes/Stg.h)+ mkLocalBlockLabel :: Unique -> CLabel mkLocalBlockLabel u = LocalBlockLabel u @@ -571,7 +600,7 @@ -- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel mkPrimCallLabel (PrimCall str pkg)- = CmmLabel pkg str CmmPrimCall+ = CmmLabel pkg (NeedExternDecl True) str CmmPrimCall -- Constructing ForeignLabels@@ -609,7 +638,7 @@ -- Closure defined in haskell (.hs) isStaticClosureLabel (IdLabel _ _ Closure) = True -- Closure defined in cmm-isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True+isStaticClosureLabel (CmmLabel _ _ _ CmmClosure) = True isStaticClosureLabel _lbl = False -- | Whether label is a .rodata label@@ -621,7 +650,7 @@ isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True -- info table defined in cmm (.cmm)-isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True+isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True isSomeRODataLabel _lbl = False -- | Whether label is points to some kind of info table@@ -703,7 +732,7 @@ toClosureLbl :: CLabel -> CLabel toClosureLbl (IdLabel n c _) = IdLabel n c Closure-toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure+toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure toClosureLbl l = pprPanic "toClosureLbl" (ppr l) toSlowEntryLbl :: CLabel -> CLabel@@ -718,16 +747,16 @@ 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 str CmmInfo) = CmmLabel m str CmmEntry-toEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet+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) 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 str CmmEntry) = CmmLabel m str CmmInfo-toInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo+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) hasHaskellName :: CLabel -> Maybe Name@@ -779,10 +808,13 @@ needsCDecl (AsmTempDerivedLabel _ _) = False needsCDecl (RtsLabel _) = False -needsCDecl (CmmLabel pkgId _ _)+needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)+ -- local labels mustn't have it+ | not external = False+ -- Prototypes for labels defined in the runtime system are imported -- into HC files via includes/Stg.h.- | pkgId == rtsUnitId = False+ | pkgId == rtsUnitId = False -- For other labels we inline one into the HC file directly. | otherwise = True@@ -907,7 +939,7 @@ externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (LocalBlockLabel _) = False-externallyVisibleCLabel (CmmLabel _ _ _) = True+externallyVisibleCLabel (CmmLabel _ _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (CC_Label _) = True@@ -950,14 +982,14 @@ -- whether it be code, data, or static GC object. labelType :: CLabel -> CLabelType labelType (IdLabel _ _ info) = idInfoLabelType info-labelType (CmmLabel _ _ CmmData) = DataLabel-labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel-labelType (CmmLabel _ _ CmmCode) = CodeLabel-labelType (CmmLabel _ _ CmmInfo) = DataLabel-labelType (CmmLabel _ _ CmmEntry) = CodeLabel-labelType (CmmLabel _ _ CmmPrimCall) = CodeLabel-labelType (CmmLabel _ _ CmmRetInfo) = DataLabel-labelType (CmmLabel _ _ CmmRet) = CodeLabel+labelType (CmmLabel _ _ _ CmmData) = DataLabel+labelType (CmmLabel _ _ _ CmmClosure) = GcPtrLabel+labelType (CmmLabel _ _ _ CmmCode) = CodeLabel+labelType (CmmLabel _ _ _ CmmInfo) = DataLabel+labelType (CmmLabel _ _ _ CmmEntry) = CodeLabel+labelType (CmmLabel _ _ _ CmmPrimCall) = CodeLabel+labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel+labelType (CmmLabel _ _ _ CmmRet) = CodeLabel labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel@@ -1027,7 +1059,7 @@ -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library.- CmmLabel pkg _ _+ CmmLabel pkg _ _ _ | os == OSMinGW32 -> externalDynamicRefs && (this_pkg /= pkg) | otherwise ->@@ -1233,9 +1265,9 @@ -- with a letter so the label will be legal assembly code. -pprCLbl (CmmLabel _ str CmmCode) = ftext str-pprCLbl (CmmLabel _ str CmmData) = ftext str-pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str+pprCLbl (CmmLabel _ _ str CmmCode) = ftext str+pprCLbl (CmmLabel _ _ str CmmData) = ftext str+pprCLbl (CmmLabel _ _ str CmmPrimCall) = ftext str pprCLbl (LocalBlockLabel u) = tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u@@ -1278,19 +1310,19 @@ else (sLit "_noupd_entry")) ] -pprCLbl (CmmLabel _ fs CmmInfo)+pprCLbl (CmmLabel _ _ fs CmmInfo) = ftext fs <> text "_info" -pprCLbl (CmmLabel _ fs CmmEntry)+pprCLbl (CmmLabel _ _ fs CmmEntry) = ftext fs <> text "_entry" -pprCLbl (CmmLabel _ fs CmmRetInfo)+pprCLbl (CmmLabel _ _ fs CmmRetInfo) = ftext fs <> text "_info" -pprCLbl (CmmLabel _ fs CmmRet)+pprCLbl (CmmLabel _ _ fs CmmRet) = ftext fs <> text "_ret" -pprCLbl (CmmLabel _ fs CmmClosure)+pprCLbl (CmmLabel _ _ fs CmmClosure) = ftext fs <> text "_closure" pprCLbl (RtsLabel (RtsPrimOp primop))
compiler/cmm/Cmm.hs view
@@ -9,7 +9,7 @@ CmmBlock, RawCmmDecl, RawCmmGroup, Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),- isSecConstant,+ SectionProtection(..), sectionProtection, -- ** Blocks containing lists GenBasicBlock(..), blockId,@@ -177,17 +177,33 @@ | OtherSection String deriving (Show) --- | Should a data in this section be considered constant-isSecConstant :: Section -> Bool-isSecConstant (Section t _) = case t of- Text -> True- ReadOnlyData -> True- RelocatableReadOnlyData -> True- ReadOnlyData16 -> True- CString -> True- Data -> False- UninitialisedData -> False- (OtherSection _) -> False+data SectionProtection+ = ReadWriteSection+ | ReadOnlySection+ | WriteProtectedSection -- See Note [Relocatable Read-Only Data]+ deriving (Eq)++-- | Should a data in this section be considered constant at runtime+sectionProtection :: Section -> SectionProtection+sectionProtection (Section t _) = case t of+ Text -> ReadOnlySection+ ReadOnlyData -> ReadOnlySection+ RelocatableReadOnlyData -> WriteProtectedSection+ ReadOnlyData16 -> ReadOnlySection+ CString -> ReadOnlySection+ Data -> ReadWriteSection+ UninitialisedData -> ReadWriteSection+ (OtherSection _) -> ReadWriteSection++{-+Note [Relocatable Read-Only Data]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Relocatable data are only read-only after relocation at the start of the+program. They should be writable from the source code until then. Failure to+do so would end up in segfaults at execution when using linkers that do not+enforce writability of those sections, such as the gold linker.+-} data Section = Section SectionType CLabel
compiler/cmm/CmmCallConv.hs view
@@ -202,11 +202,16 @@ -- only use this functionality in hand-written C-- code in the RTS. realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover dflags- | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++- realLongRegs dflags ++- map XmmReg (realXmmRegNos dflags)- | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++- realFloatRegs dflags ++- realDoubleRegs dflags ++- realLongRegs dflags ++- map XmmReg (realXmmRegNos dflags)+ | passFloatArgsInXmm 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...++ | otherwise+ = map ($VGcPtr) (realVanillaRegs dflags) +++ realFloatRegs dflags +++ realDoubleRegs dflags +++ realLongRegs dflags+ -- we don't save XMM registers if they are not used for parameter passing
compiler/cmm/CmmMachOp.hs view
@@ -43,6 +43,9 @@ Most operations are parameterised by the 'Width' that they operate on. Some operations have separate signed and unsigned versions, and float and integer versions.++Note that there are variety of places in the native code generator where we+assume that the code produced for a MachOp does not introduce new blocks. -} data MachOp
compiler/cmm/CmmParse.y view
@@ -203,7 +203,6 @@ module CmmParse ( parseCmmFile ) where import GhcPrelude-import qualified Prelude import GHC.StgToCmm.ExtCode import CmmCallConv@@ -400,7 +399,7 @@ data_label :: { CmmParse CLabel } : NAME ':' {% liftP . withThisPackage $ \pkg ->- return (mkCmmDataLabel pkg $1) }+ return (mkCmmDataLabel pkg (NeedExternDecl False) $1) } statics :: { [CmmParse [CmmStatic]] } : {- empty -} { [] }@@ -1119,6 +1118,9 @@ ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ),+ ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ),+ ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), @@ -1176,7 +1178,7 @@ staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []- code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits+ code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits foreignCall :: String
compiler/cmm/PprC.hs view
@@ -128,6 +128,11 @@ pprDataExterns lits $$ pprWordArray (isSecConstant section) lbl lits +isSecConstant :: Section -> Bool+isSecConstant section = case sectionProtection section of+ ReadOnlySection -> True+ WriteProtectedSection -> True+ _ -> False -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. --
compiler/coreSyn/CorePrep.hs view
@@ -927,8 +927,10 @@ (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, [])- (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $- splitFunTy_maybe fun_ty+ (arg_ty, res_ty) =+ case splitFunTy_maybe fun_ty of+ Just as -> as+ Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr) (fs, arg') <- cpeArg top_env ss1 arg arg_ty rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest CpeCast co ->
compiler/deSugar/Coverage.hs view
@@ -113,7 +113,7 @@ dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1) - return (binds1, HpcInfo tickCount hashNo, Just modBreaks)+ return (binds1, HpcInfo tickCount hashNo, modBreaks) | otherwise = return (binds, emptyHpcInfo False, Nothing) @@ -130,23 +130,23 @@ _ -> orig_file -mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) mkModBreaks hsc_env mod count entries- | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do+ | breakpointsEnabled (hsc_dflags hsc_env) = do breakArray <- GHCi.newBreakArray hsc_env (length entries) ccs <- mkCCSArray hsc_env mod count entries let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]- return emptyModBreaks+ return $ Just $ emptyModBreaks { modBreaks_flags = breakArray , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks , modBreaks_decls = declsTicks , modBreaks_ccs = ccs }- | otherwise = return emptyModBreaks+ | otherwise = return Nothing mkCCSArray :: HscEnv -> Module -> Int -> [MixEntry_]@@ -1041,13 +1041,17 @@ coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags =- ifa (hscTarget dflags == HscInterpreted) Breakpoints $+ ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (gopt Opt_SccProfilingOn dflags && profAuto dflags /= NoProfAuto) ProfNotes $ ifa (debugLevel dflags > 0) SourceNotes [] where ifa f x xs | f = x:xs | otherwise = xs++-- | Should we produce 'Breakpoint' ticks?+breakpointsEnabled :: DynFlags -> Bool+breakpointsEnabled dflags = hscTarget dflags == HscInterpreted -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to
compiler/deSugar/DsBinds.hs view
@@ -695,20 +695,19 @@ dflags <- getDynFlags ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { Left msg -> do { warnDs NoReason msg; return Nothing } ;- Right (rule_bndrs, _fn, args) -> do+ Right (rule_bndrs, _fn, rule_lhs_args) -> do { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id- spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf+ spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf- arity_decrease = count isValArg args - count isId spec_bndrs ; rule <- dsMkUserRule this_mod is_local_id (mkFastString ("SPEC " ++ showPpr dflags poly_name)) rule_act poly_name- rule_bndrs args+ rule_bndrs rule_lhs_args (mkVarApps (Var spec_id) spec_bndrs) ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
compiler/deSugar/DsExpr.hs view
@@ -331,26 +331,47 @@ That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. -Operator sections. At first it looks as if we can convert-\begin{verbatim}- (expr op)-\end{verbatim}-to-\begin{verbatim}- \x -> op expr x-\end{verbatim} +Note [Desugaring operator sections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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-\begin{verbatim}- map (expr op) xs-\end{verbatim}-for example. So we convert instead to-\begin{verbatim}- let y = expr in \x -> op y x-\end{verbatim}-If \tr{expr} is actually just a variable, say, then the simplifier-will sort it out.++ 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. -} ds_expr _ e@(OpApp _ e1 op e2)@@ -359,17 +380,35 @@ ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } -ds_expr _ (SectionL _ expr op) -- Desugar (e !) to ((!) e)- = do { op' <- dsLExpr op- ; dsWhenNoErrs (dsLExprNoLP expr)- (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }+-- 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.+ds_expr _ e@(SectionL _ expr op) = do+ core_op <- dsLExpr op+ x_core <- dsLExpr expr+ case splitFunTys (exprType core_op) of+ -- Binary operator section+ (x_ty:y_ty:_, _) -> do+ dsWhenNoErrs+ (mapM newSysLocalDsNoLP [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])) --- dsLExpr (SectionR op expr) -- \ x -> op x expr+ -- 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]. ds_expr _ e@(SectionR _ op expr) = do core_op <- dsLExpr op- -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)- -- See comment with SectionL y_core <- dsLExpr expr dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty]) (\[x_id, y_id] -> bindNonRec y_id y_core $
compiler/ghci/Linker.hs view
@@ -1310,6 +1310,7 @@ ("Loading package " ++ sourcePackageIdString pkg ++ " ... ") -- See comments with partOfGHCi+#if defined(CAN_LOAD_DLL) when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks hsc_env platform pkg -- See Note [Crash early load_dyn and locateLib]@@ -1318,7 +1319,7 @@ -- 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.@@ -1453,10 +1454,15 @@ -- O(n). Loading an import library is also O(n) so in general we prefer -- shared libraries because they are simpler and faster. --- = findDll user `orElse`+ =+#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`@@ -1520,7 +1526,13 @@ full = dllpath $ search lib_so_name lib_dirs gcc name = liftM (fmap Archive) $ search name lib_dirs files = import_libs ++ arch_files- in apply $ short : full : map gcc 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
compiler/llvmGen/LlvmCodeGen/Base.hs view
@@ -33,7 +33,9 @@ strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, getGlobalPtr, generateExternDecls, - aliasify, llvmDefLabel+ aliasify, llvmDefLabel,++ padLiveArgs, isFPR ) where #include "GhclibHsVersions.h"@@ -43,12 +45,15 @@ import Llvm import LlvmCodeGen.Regs+import Panic +import PprCmm () import CLabel-import GHC.Platform.Regs ( activeStgRegs )+import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import DynFlags import FastString import Cmm hiding ( succ )+import CmmUtils (regsOverlap) import Outputable as Outp import GHC.Platform import UniqFM@@ -62,7 +67,8 @@ import Data.Maybe (fromJust) import Control.Monad (ap) import Data.Char (isDigit)-import Data.List (intercalate)+import Data.List (sortBy, groupBy, intercalate)+import Data.Ord (comparing) import qualified Data.List.NonEmpty as NE -- ----------------------------------------------------------------------------@@ -152,16 +158,96 @@ -- | A Function's arguments llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] llvmFunArgs dflags live =- map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))- where platform = targetPlatform dflags- isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live- isPassed r = not (isSSE r) || isLive r- isSSE (FloatReg _) = True- isSSE (DoubleReg _) = True- isSSE (XmmReg _) = True- isSSE (YmmReg _) = True- isSSE (ZmmReg _) = True- isSSE _ = False+ map (lmGlobalRegArg dflags) (filter isPassed allRegs)+ where allRegs = activeStgRegs (targetPlatform dflags)+ paddingRegs = padLiveArgs dflags live+ isLive r = r `elem` alwaysLive+ || r `elem` live+ || r `elem` paddingRegs+ isPassed r = not (isFPR r) || isLive r+++isFPR :: GlobalReg -> Bool+isFPR (FloatReg _) = True+isFPR (DoubleReg _) = True+isFPR (XmmReg _) = True+isFPR (YmmReg _) = True+isFPR (ZmmReg _) = True+isFPR _ = False++-- | Return a list of "padding" registers for LLVM function calls.+--+-- When we generate LLVM function signatures, we can't just make any register+-- alive on function entry. Instead, we need to insert fake arguments of the+-- same register class until we are sure that one of them is mapped to the+-- register we want alive. E.g. to ensure that F5 is alive, we may need to+-- insert fake arguments mapped to F1, F2, F3 and F4.+--+-- Invariant: Cmm FPR regs with number "n" maps to real registers with number+-- "n" If the calling convention uses registers in a different order or if the+-- invariant doesn't hold, this code probably won't be correct.+padLiveArgs :: DynFlags -> LiveGlobalRegs -> LiveGlobalRegs+padLiveArgs dflags live =+ if platformUnregisterised platform+ then [] -- not using GHC's register convention for platform.+ else padded+ where+ platform = targetPlatform dflags++ ----------------------------------+ -- handle floating-point registers (FPR)++ fprLive = filter isFPR live -- real live FPR registers++ -- we group live registers sharing the same classes, i.e. that use the same+ -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg+ -- all use the same real regs on X86-64 (XMM registers).+ --+ classes = groupBy sharesClass fprLive+ sharesClass a b = regsOverlap dflags (norm a) (norm b) -- check if mapped to overlapping registers+ norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family++ -- For each class, we just have to fill missing registers numbers. We use+ -- the constructor of the greatest register to build padding registers.+ --+ -- E.g. sortedRs = [ F2, XMM4, D5]+ -- output = [D1, D3]+ padded = concatMap padClass classes+ padClass rs = go sortedRs [1..]+ where+ sortedRs = sortBy (comparing fpr_num) rs+ maxr = last sortedRs+ ctor = fpr_ctor maxr++ go [] _ = []+ go (c1:c2:_) _ -- detect bogus case (see #17920)+ | fpr_num c1 == fpr_num c2+ , Just real <- globalRegMaybe platform c1+ = sorryDoc "LLVM code generator" $+ text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>+ text ") both alive AND mapped to the same real register: " <> ppr real <>+ text ". This isn't currently supported by the LLVM backend."+ go (c:cs) (f:fs)+ | fpr_num c == f = go cs fs -- already covered by a real register+ | otherwise = ctor f : go (c:cs) fs -- add padding register+ go _ _ = undefined -- unreachable++ fpr_ctor :: GlobalReg -> Int -> GlobalReg+ fpr_ctor (FloatReg _) = FloatReg+ fpr_ctor (DoubleReg _) = DoubleReg+ fpr_ctor (XmmReg _) = XmmReg+ fpr_ctor (YmmReg _) = YmmReg+ fpr_ctor (ZmmReg _) = ZmmReg+ fpr_ctor _ = error "fpr_ctor expected only FPR regs"++ fpr_num :: GlobalReg -> Int+ fpr_num (FloatReg i) = i+ fpr_num (DoubleReg i) = i+ fpr_num (XmmReg i) = i+ fpr_num (YmmReg i) = i+ fpr_num (ZmmReg i) = i+ fpr_num _ = error "fpr_num expected only FPR regs"+ -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr]
compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP, GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmProc to LLVM code.@@ -37,6 +37,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Writer+import Control.Monad import qualified Data.Semigroup as Semigroup import Data.List ( nub )@@ -1821,7 +1822,7 @@ isLive r = r `elem` alwaysLive || r `elem` live dflags <- getDynFlags- stmtss <- flip mapM assignedRegs $ \reg ->+ stmtss <- forM assignedRegs $ \reg -> case reg of CmmLocal (LocalReg un _) -> do let (newv, stmts) = allocReg reg@@ -1846,30 +1847,37 @@ -- STG Liveness optimisation done here. funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do+ dflags <- getDynFlags - -- Have information and liveness optimisation is enabled?- let liveRegs = alwaysLive ++ live- isSSE (FloatReg _) = True- isSSE (DoubleReg _) = True- isSSE (XmmReg _) = True- isSSE (YmmReg _) = True- isSSE (ZmmReg _) = True- isSSE _ = False+ let paddingRegs = padLiveArgs dflags live -- Set to value or "undef" depending on whether the register is -- actually live- dflags <- getDynFlags let loadExpr r = do (v, _, s) <- getCmmRegVal (CmmGlobal r) return (Just $ v, s) loadUndef r = do let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (Just $ LMLitVar $ LMUndefLit ty, nilOL)- platform <- getDynFlag targetPlatform- loads <- flip mapM (activeStgRegs platform) $ \r -> case () of- _ | r `elem` liveRegs -> loadExpr r- | not (isSSE r) -> loadUndef r- | otherwise -> return (Nothing, nilOL)++ -- Note that floating-point registers in `activeStgRegs` must be sorted+ -- according to the calling convention.+ -- E.g. for X86:+ -- GOOD: F1,D1,XMM1,F2,D2,XMM2,...+ -- BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...+ -- As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't+ -- want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1+ -- and D1 -> XMM2.+ let allRegs = activeStgRegs (targetPlatform dflags)+ loads <- forM allRegs $ \r -> if+ -- load live registers+ | r `elem` alwaysLive -> loadExpr r+ | r `elem` live -> loadExpr r+ -- load all non Floating-Point Registers+ | not (isFPR r) -> loadUndef r+ -- load padding Floating-Point Registers+ | r `elem` paddingRegs -> loadUndef r+ | otherwise -> return (Nothing, nilOL) let (vars, stmts) = unzip loads return (catMaybes vars, concatOL stmts)
compiler/llvmGen/LlvmCodeGen/Data.hs view
@@ -83,7 +83,8 @@ Section CString _ -> if (platformArch platform == ArchS390X) then Just 2 else Just 1 _ -> Nothing- const = if isSecConstant sec then Constant else Global+ const = if sectionProtection sec == ReadOnlySection+ then Constant else Global varDef = LMGlobalVar label tyAlias link lmsec align const globDef = LMGlobal varDef struct
compiler/main/DriverPipeline.hs view
@@ -2119,6 +2119,23 @@ 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 ()@@ -2126,34 +2143,13 @@ let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags)- ld_r args cc = SysTools.runLink dflags ([- SysTools.Option "-nostdlib",- SysTools.Option "-Wl,-r"- ]- -- See Note [No PIE while linking] in DynFlags- ++ (if toolSettings_ccSupportsNoPie toolSettings'- then [SysTools.Option "-no-pie"]- else [])-- ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]- then []- else [SysTools.Option "-nodefaultlibs"])- ++ (if osInfo == OSFreeBSD- then [SysTools.Option "-L/usr/lib"]- else [])- -- gcc on sparc sets -Wl,--relax implicitly, but- -- -r and --relax are incompatible for ld, so- -- disable --relax explicitly.- ++ (if platformArch (targetPlatform dflags)- `elem` [ArchSPARC, ArchSPARC64]- && ldIsGnuLd- then [SysTools.Option "-Wl,-no-relax"]- else [])+ ld_r args = SysTools.runMergeObjects dflags ( -- See Note [Produce big objects on Windows]- ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"- | OSMinGW32 == osInfo- , not $ target32Bit (targetPlatform dflags)- ]+ concat+ [ [SysTools.Option "--oformat", SysTools.Option "pe-bigobj-x86-64"]+ | OSMinGW32 == osInfo+ , not $ target32Bit (targetPlatform dflags)+ ] ++ map SysTools.Option ld_build_id ++ [ SysTools.Option "-o", SysTools.FileOption "" output_fn ]@@ -2162,25 +2158,24 @@ -- 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' = ["-Wl,--build-id=none"]+ ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] | otherwise = [] - ccInfo <- getCompilerInfo dflags 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 [SysTools.FileOption "" script] ccInfo+ ld_r [SysTools.FileOption "" script] else if toolSettings_ldSupportsFilelist toolSettings' then do filelist <- newTempName dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files- ld_r [SysTools.Option "-Wl,-filelist",- SysTools.FileOption "-Wl," filelist] ccInfo+ ld_r [SysTools.Option "-filelist",+ SysTools.FileOption "" filelist] else do- ld_r (map (SysTools.FileOption "") o_files) ccInfo+ ld_r (map (SysTools.FileOption "") o_files) -- ----------------------------------------------------------------------------- -- Misc.
compiler/main/SysTools/Settings.hs view
@@ -141,6 +141,8 @@ as_args = map Option cc_args ld_prog = cc_prog ld_args = map Option (cc_args ++ words cc_link_args_str)+ ld_r_prog <- getSetting "Merge objects command"+ ld_r_args <- getSetting "Merge objects flags" llvmTarget <- getSetting "LLVM target" @@ -202,6 +204,7 @@ , toolSettings_pgm_c = cc_prog , toolSettings_pgm_a = (as_prog, as_args) , toolSettings_pgm_l = (ld_prog, ld_args)+ , toolSettings_pgm_lm = (ld_r_prog, map Option $ words ld_r_args) , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) , toolSettings_pgm_T = touch_path , toolSettings_pgm_windres = windres_path@@ -220,6 +223,7 @@ , toolSettings_opt_cxx = cxx_args , toolSettings_opt_a = [] , toolSettings_opt_l = []+ , toolSettings_opt_lm = [] , toolSettings_opt_windres = [] , toolSettings_opt_lcc = [] , toolSettings_opt_lo = []
compiler/main/SysTools/Tasks.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- -- Tasks running external programs for SysTools@@ -299,6 +300,20 @@ ld_postfix = tail . snd . ld_warn_break 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.+#if defined(mingw32_HOST_OS)+ mb_env <- getGccEnv args2+ runSomethingResponseFile dflags id "Merge objects" p args2 mb_env+#else+ runSomething dflags "Merge objects" p args2+#endif runLibtool :: DynFlags -> [Option] -> IO () runLibtool dflags args = traceToolCommand dflags "libtool" $ do
compiler/nativeGen/X86/CodeGen.hs view
@@ -292,11 +292,11 @@ Instead we now return the new basic block if a statement causes a change in the current block and use the block for all following statements. -For this reason genCCall is also split into two parts.-One for calls which *won't* change the basic blocks in-which successive instructions will be placed.-A different one for calls which *are* known to change the-basic block.+For this reason genCCall is also split into two parts. One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings). A different one for calls+which *are* known to change the basic block. -} @@ -1037,6 +1037,9 @@ tmp. This is likely to be better, because the reg alloc can eliminate this reg->reg move here (it won't eliminate the other one, because the move is into the fixed %ecx).+ * in the case of C calls the use of ecx here can interfere with arguments.+ We avoid this with the hack described in Note [Evaluate C-call+ arguments before placing in destination registers] -} shift_code width instr x y{-amount-} = do x_code <- getAnyReg x@@ -2614,9 +2617,12 @@ return code _ -> panic "genCCall: Wrong number of arguments/results for mul2" - _ -> if is32Bit- then genCCall32' dflags target dest_regs args- else genCCall64' dflags target dest_regs args+ _ -> do+ (instrs0, args') <- evalArgs bid args+ instrs1 <- if is32Bit+ then genCCall32' dflags target dest_regs args'+ else genCCall64' dflags target dest_regs args'+ return (instrs0 `appOL` instrs1) where divOp1 platform signed width results [arg_x, arg_y] = divOp platform signed width results Nothing arg_x arg_y@@ -2678,6 +2684,83 @@ return code addSubIntC _ _ _ _ _ _ _ _ = panic "genCCall: Wrong number of arguments/results for addSubIntC"++{-+Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++ (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++ mov _s2hp, $arg1 # place first argument+ mov _s2hq, $arg2 # place second argument++ # Compute 1 << _s2hz+ mov _s2hz, %rcx+ shl %cl, $tmp++ # Compute (_s2hw | (1 << _s2hz))+ mov _s2hw, $arg3+ or $tmp, $arg3++ # Perform the call+ call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call) since outOfLineCmmOp produces the call via+(stmtToInstrs (CmmUnsafeForeignCall ...)), which will ultimately end up+back in genCCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+ | any mightContainMachOp actuals = do+ regs_blks <- mapM evalArg actuals+ return (concatOL $ map fst regs_blks, map snd regs_blks)+ | otherwise = return (nilOL, actuals)+ where+ mightContainMachOp (CmmReg _) = False+ mightContainMachOp (CmmRegOff _ _) = False+ mightContainMachOp (CmmLit _) = False+ mightContainMachOp _ = True++ evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+ evalArg actual = do+ dflags <- getDynFlags+ lreg <- newLocalReg $ cmmExprType dflags actual+ (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+ -- The above assignment shouldn't change the current block+ MASSERT(isNothing bid1)+ return (instrs, CmmReg $ CmmLocal lreg)++ newLocalReg :: CmmType -> NatM LocalReg+ newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty -- Note [DIV/IDIV for bytes] --
compiler/prelude/PrelInfo.hs view
@@ -58,6 +58,7 @@ import Avail import PrimOp import DataCon+import BasicTypes import Id import Name import NameEnv@@ -121,14 +122,17 @@ = 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 Unit (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- , concatMap wired_tycon_kk_names wiredInTyCons- -- Does not include tuples- , concatMap wired_tycon_kk_names typeNatTyCons- , map idName wiredInIds , map (idName . primOpId) allThePrimOps , map (idName . primOpWrapperId) allThePrimOps
compiler/rename/RnNames.hs view
@@ -635,9 +635,12 @@ | otherwise = return (extendGlobalRdrEnv env gre) where- name = gre_name gre- occ = nameOccName name- dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)+ 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') {- *********************************************************************@@ -1611,9 +1614,8 @@ = do { imports' <- getMinimalImports imports_w_usage ; this_mod <- getModule ; dflags <- getDynFlags- ; liftIO $- do { h <- openFile (mkFilename dflags this_mod) WriteMode- ; printForUser dflags h neverQualify (vcat (map ppr imports')) }+ ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->+ printForUser dflags h neverQualify (vcat (map ppr imports')) -- The neverQualify is important. We are printing Names -- but they are in the context of an 'import' decl, and -- we never qualify things inside there@@ -1769,14 +1771,13 @@ = addErrAt (getSrcSpan (last sorted_names)) $ -- Report the error at the later location vcat [text "Multiple declarations of" <+>- quotes (ppr (nameOccName name)),+ quotes (ppr (greOccName gre)), -- NB. print the OccName, not the Name, because the -- latter might not be in scope in the RdrEnv and so will -- be printed qualified. text "Declared at:" <+> vcat (map (ppr . nameSrcLoc) sorted_names)] where- name = gre_name gre sorted_names = sortWith nameSrcLoc (map gre_name gres)
compiler/simplCore/SimplUtils.hs view
@@ -830,6 +830,21 @@ Doing this to either side confounds tools like HERMIT, which seek to reason about and apply the RULES as originally written. See #10829. +There is, however, one case where we are pretty much /forced/ to transform the+LHS of a rule: postInlineUnconditionally. For instance, in the case of++ let f = g @Int in f++We very much want to inline f into the body of the let. However, to do so (and+be able to safely drop f's binding) we must inline into all occurrences of f,+including those in the LHS of rules.++This can cause somewhat surprising results; for instance, in #18162 we found+that a rule template contained ticks in its arguments, because+postInlineUnconditionally substituted in a trivial expression that contains+ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for+details.+ Note [No eta expansion in stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have a stable unfolding@@ -1251,6 +1266,10 @@ with both a and b marked NOINLINE. But that seems incompatible with our new view that inlining is like a RULE, so I'm sticking to the 'active' story for now.++NB: unconditional inlining of this sort can introduce ticks in places that+may seem surprising; for instance, the LHS of rules. See Note [Simplfying+rules] for details. -} postInlineUnconditionally
compiler/specialise/Specialise.hs view
@@ -20,7 +20,7 @@ import Module( Module, HasModule(..) ) import Coercion( Coercion ) import CoreMonad-import qualified CoreSubst+import qualified CoreSubst as Core import CoreUnfold import Var ( isLocalVar ) import VarSet@@ -28,13 +28,14 @@ import CoreSyn import Rules import CoreOpt ( collectBindersPushingCo )-import CoreUtils ( exprIsTrivial, mkCast, exprType )+import CoreUtils ( exprIsTrivial, mkCast, exprType, getIdFromTrivialExpr_maybe ) import CoreFVs import CoreArity ( etaExpandToJoinPointRule ) import UniqSupply import Name import MkId ( voidArgId, voidPrimId )-import Maybes ( mapMaybe, isJust )+import TysPrim ( voidPrimTy )+import Maybes ( mapMaybe, maybeToList, isJust ) import MonadUtils ( foldlM ) import BasicTypes import HscTypes@@ -605,7 +606,7 @@ -- 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 = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $+ top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $ bindersOfBinds binds , se_interesting = emptyVarSet } @@ -635,189 +636,12 @@ See #10491 -} --- | An argument that we might want to specialise.--- See Note [Specialising Calls] for the nitty gritty details.-data SpecArg- =- -- | Type arguments that should be specialised, due to appearing- -- free in the type of a 'SpecDict'.- SpecType Type- -- | Type arguments that should remain polymorphic.- | UnspecType- -- | Dictionaries that should be specialised.- | SpecDict DictExpr- -- | Value arguments that should not be specialised.- | UnspecArg -instance Outputable SpecArg where- ppr (SpecType t) = text "SpecType" <+> ppr t- ppr UnspecType = text "UnspecType"- ppr (SpecDict d) = text "SpecDict" <+> ppr d- ppr UnspecArg = text "UnspecArg"--getSpecDicts :: [SpecArg] -> [DictExpr]-getSpecDicts = mapMaybe go- where- go (SpecDict d) = Just d- go _ = Nothing--getSpecTypes :: [SpecArg] -> [Type]-getSpecTypes = mapMaybe go- where- go (SpecType t) = Just t- go _ = Nothing--isUnspecArg :: SpecArg -> Bool-isUnspecArg UnspecArg = True-isUnspecArg UnspecType = True-isUnspecArg _ = False--isValueArg :: SpecArg -> Bool-isValueArg UnspecArg = True-isValueArg (SpecDict _) = True-isValueArg _ = False---- | Given binders from an original function 'f', and the 'SpecArg's--- corresponding to its usage, compute everything necessary to build--- a specialisation.------ We will use a running example. Consider the function------ foo :: forall a b. Eq a => Int -> blah--- foo @a @b dEqA i = blah------ which is called with the 'CallInfo'------ [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]------ We'd eventually like to build the RULE------ RULE "SPEC foo @T1 _"--- forall @a @b (dEqA' :: Eq a).--- foo @T1 @b dEqA' = $sfoo @b------ and the specialisation '$sfoo'------ $sfoo :: forall b. Int -> blah--- $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah------ The cases for 'specHeader' below are presented in the same order as this--- running example. The result of 'specHeader' for this example is as follows:------ ( -- Returned arguments--- env + [a -> T1, deqA -> dEqA']--- , []------ -- RULE helpers--- , [b, dx', i]--- , [T1, b, dx', i]------ -- Specialised function helpers--- , [b, i]--- , [dx]--- , [T1, b, dx_spec, i]--- )-specHeader- :: SpecEnv- -> [CoreBndr] -- The binders from the original function 'f'- -> [SpecArg] -- From the CallInfo- -> SpecM ( -- Returned arguments- SpecEnv -- Substitution to apply to the body of 'f'- , [CoreBndr] -- All the remaining unspecialised args from the original function 'f'-- -- RULE helpers- , [CoreBndr] -- Binders for the RULE- , [CoreArg] -- Args for the LHS of the rule-- -- Specialised function helpers- , [CoreBndr] -- Binders for $sf- , [DictBind] -- Auxiliary dictionary bindings- , [CoreExpr] -- Specialised arguments for unfolding- )---- We want to specialise on type 'T1', and so we must construct a substitution--- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding--- details.-specHeader env (bndr : bndrs) (SpecType t : args)- = do { let env' = extendTvSubstList env [(bndr, t)]- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)- <- specHeader env' bndrs args- ; pure ( env''- , unused_bndrs- , rule_bs- , Type t : rule_es- , bs'- , dx- , Type t : spec_args- )- }---- Next we have a type that we don't want to specialise. We need to perform--- a substitution on it (in case the type refers to 'a'). Additionally, we need--- to produce a binder, LHS argument and RHS argument for the resulting rule,--- /and/ a binder for the specialised body.-specHeader env (bndr : bndrs) (UnspecType : args)- = do { let (env', bndr') = substBndr env bndr- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)- <- specHeader env' bndrs args- ; pure ( env''- , unused_bndrs- , bndr' : rule_bs- , varToCoreExpr bndr' : rule_es- , bndr' : bs'- , dx- , varToCoreExpr bndr' : spec_args- )- }---- Next we want to specialise the 'Eq a' dict away. We need to construct--- a wildcard binder to match the dictionary (See Note [Specialising Calls] for--- the nitty-gritty), as a LHS rule and unfolding details.-specHeader env (bndr : bndrs) (SpecDict d : args)- = do { inst_dict_id <- newDictBndr env bndr- ; let (rhs_env2, dx_binds, spec_dict_args')- = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]- ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)- <- specHeader rhs_env2 bndrs args- ; pure ( env'- , unused_bndrs- -- See Note [Evidence foralls]- , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs- , varToCoreExpr inst_dict_id : rule_es- , bs'- , dx_binds ++ dx- , spec_dict_args' ++ spec_args- )- }---- Finally, we have the unspecialised argument 'i'. We need to produce--- a binder, LHS and RHS argument for the RULE, and a binder for the--- specialised body.------ NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is--- why 'i' doesn't appear in our RULE above. But we have no guarantee that--- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so--- this case must be here.-specHeader env (bndr : bndrs) (UnspecArg : args)- = do { let (env', bndr') = substBndr env bndr- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)- <- specHeader env' bndrs args- ; pure ( env''- , unused_bndrs- , bndr' : rule_bs- , varToCoreExpr bndr' : rule_es- , bndr' : bs'- , dx- , varToCoreExpr bndr' : spec_args- )- }---- Return all remaining binders from the original function. These have the--- invariant that they should all correspond to unspecialised arguments, so--- it's safe to stop processing at this point.-specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])-specHeader env [] _ = pure (env, [], [], [], [], [], [])-+{- *********************************************************************+* *+ Specialising imported functions+* *+********************************************************************* -} -- | Specialise a set of calls to imported bindings specImports :: DynFlags@@ -1034,7 +858,7 @@ -} data SpecEnv- = SE { se_subst :: CoreSubst.Subst+ = SE { se_subst :: Core.Subst -- We carry a substitution down: -- a) we must clone any binding that might float outwards, -- to avoid name clashes@@ -1048,8 +872,14 @@ -- See Note [Interesting dictionary arguments] } +instance Outputable SpecEnv where+ ppr (SE { se_subst = subst, se_interesting = interesting })+ = text "SE" <+> braces (sep $ punctuate comma+ [ text "subst =" <+> ppr subst+ , text "interesting =" <+> ppr interesting ])+ specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v+specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) @@ -1110,6 +940,18 @@ -- All done ; return (foldr Let body' binds', uds) } +--------------+specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)+-- The binders have been substituted, but the body has not+specLam env bndrs body+ | null bndrs+ = specExpr env body+ | otherwise+ = do { (body', uds) <- specExpr env body+ ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds+ ; 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]]@@ -1117,6 +959,7 @@ -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish +-------------- specCase :: SpecEnv -> CoreExpr -- Scrutinee, already done -> Id -> [CoreAlt]@@ -1142,7 +985,7 @@ subst_prs = (case_bndr, Var case_bndr_flt) : [ (arg, Var sc_flt) | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]- env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs+ env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs , se_interesting = se_interesting env_rhs `extendVarSetList` (case_bndr_flt : sc_args_flt) } @@ -1239,8 +1082,14 @@ -- No calls for binders of this bind specBind rhs_env (NonRec fn rhs) body_uds = do { (rhs', rhs_uds) <- specExpr rhs_env rhs- ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs + ; let zapped_fn = zapIdDemandInfo fn+ -- We zap the demand info because the binding may float,+ -- which would invaidate the demand info (see #17810 for example).+ -- Destroying demand info is not terrible; specialisation is+ -- always followed soon by demand analysis.+ ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs+ ; let pairs = spec_defns ++ [(fn', rhs')] -- fn' mentions the spec_defns in its rules, -- so put the latter first@@ -1359,8 +1208,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs -- The first case is the interesting one- | callSpecArity pis <= fn_arity -- See Note [Specialisation Must Preserve Sharing]- && notNull calls_for_me -- And there are some calls to specialise+ | notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn)) -- Don't specialise NOINLINE things -- See Note [Auto-specialisation and RULES]@@ -1380,27 +1228,23 @@ -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) where- _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs- , ppr (idInlineActivation fn) ]+ _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] - fn_type = idType fn- fn_arity = idArity fn- fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here- pis = fst $ splitPiTys fn_type- theta = getTheta pis- n_dicts = length theta- inl_prag = idInlinePragma fn- inl_act = inlinePragmaActivation inl_prag- is_local = isLocalId fn+ fn_type = idType fn+ fn_arity = idArity fn+ fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here+ inl_prag = idInlinePragma fn+ inl_act = inlinePragmaActivation inl_prag+ is_local = isLocalId fn+ is_dfun = isDFunId fn -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] - (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs- -- See Note [Account for casts in binding]- rhs_tyvars = filter isTyVar rhs_bndrs+ (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs+ -- See Note [Account for casts in binding] - in_scope = CoreSubst.substInScope (se_subst env)+ in_scope = Core.substInScope (se_subst env) already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool already_covered dflags new_rules args -- Note [Specialisations already covered]@@ -1415,38 +1259,54 @@ spec_call :: SpecInfo -- Accumulating parameter -> CallInfo -- Call instance -> SpecM SpecInfo- spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)- (CI { ci_key = call_args, ci_arity = call_arity })- = ASSERT(call_arity <= fn_arity)+ spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })+ = -- See Note [Specialising Calls]+ do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg+ | otherwise = call_args+ -- See Note [Specialising DFuns]+ ; ( useful, rhs_env2, leftover_bndrs+ , rule_bndrs, rule_lhs_args+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args - -- See Note [Specialising Calls]- do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)- <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args- ; let rhs_body' = mkLams unused_bndrs rhs_body+-- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci+-- , text "useful: " <+> ppr useful+-- , text "rule_bndrs:" <+> ppr rule_bndrs+-- , text "lhs_args: " <+> ppr rule_lhs_args+-- , text "spec_bndrs:" <+> ppr spec_bndrs1+-- , text "spec_args: " <+> ppr spec_args+-- , text "dx_binds: " <+> ppr dx_binds+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)+-- , ppr dx_binds ]) $+-- return ()+ ; dflags <- getDynFlags- ; if already_covered dflags rules_acc rule_args+ ; if not useful -- No useful specialisation+ || already_covered dflags rules_acc rule_lhs_args then return spec_acc- else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids- -- , text "rhs_env2" <+> ppr (se_subst rhs_env2)- -- , ppr dx_binds ]) $- do- { -- Figure out the type of the specialised function- let body = mkLams unspec_bndrs rhs_body'- body_ty = substTy rhs_env2 $ exprType body- (lam_extra_args, app_args) -- See Note [Specialisations Must Be Lifted]- | isUnliftedType body_ty -- C.f. WwLib.mkWorkerArgs- , not (isJoinId fn)- = ([voidArgId], voidPrimId : unspec_bndrs)- | otherwise = ([], unspec_bndrs)- join_arity_change = length app_args - length rule_args+ else+ do { -- Run the specialiser on the specialised RHS+ -- The "1" suffix is before we maybe add the void arg+ ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body+ ; let spec_fn_ty1 = exprType spec_rhs1++ -- Maybe add a void arg to the specialised function,+ -- to avoid unlifted bindings+ -- See Note [Specialisations Must Be Lifted]+ -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs+ add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)+ (spec_bndrs, spec_rhs, spec_fn_ty)+ | add_void_arg = ( voidPrimId : spec_bndrs1+ , Lam voidArgId spec_rhs1+ , mkVisFunTy voidPrimTy spec_fn_ty1)+ | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)++ join_arity_decr = length rule_lhs_args - length spec_bndrs spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn- = Just (orig_join_arity + join_arity_change)+ = Just (orig_join_arity - join_arity_decr) | otherwise = Nothing - ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)- ; let spec_id_ty = exprType spec_rhs- ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity+ ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity ; this_mod <- getModule ; let -- The rule to put in the function's specialisation is:@@ -1474,13 +1334,12 @@ inl_act -- Note [Auto-specialisation and RULES] (idName fn) rule_bndrs- rule_args- (mkVarApps (Var spec_f) app_args)+ rule_lhs_args+ (mkVarApps (Var spec_fn) spec_bndrs) spec_rule = case isJoinId_maybe fn of- Just join_arity -> etaExpandToJoinPointRule join_arity- rule_wout_eta+ Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta Nothing -> rule_wout_eta -- Add the { d1' = dx1; d2' = dx2 } usage stuff@@ -1499,21 +1358,22 @@ = (inl_prag { inl_inline = NoUserInline }, noUnfolding) | otherwise- = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf)-- spec_app e = e `mkApps` spec_args+ = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args)+ rule_lhs_args fn_unf) -------------------------------------- -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in Simplify -- Copy InlinePragma information from the parent Id.- -- So if f has INLINE[1] so does spec_f- spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts)- `setInlinePragma` spec_inl_prag- `setIdUnfolding` spec_unf- `asJoinId_maybe` spec_join_arity+ -- So if f has INLINE[1] so does spec_fn+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs+ spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)+ `setInlinePragma` spec_inl_prag+ `setIdUnfolding` spec_unf+ `asJoinId_maybe` spec_join_arity - _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty+ _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type+ , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty , ppr rhs_bndrs, ppr call_args , ppr spec_rule ]@@ -1524,8 +1384,19 @@ , spec_uds `plusUDs` uds_acc ) } } -{- Note [Specialisation Must Preserve Sharing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Specialising DFuns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DFuns have a special sort of unfolding (DFunUnfolding), and these are+hard to specialise a DFunUnfolding to give another DFunUnfolding+unless the DFun is fully applied (#18120). So, in the case of DFunIds+we simply extend the CallKey with trailing UnspecArgs, so we'll+generate a rule that completely saturates the DFun.++There is an ASSERT that checks this, in the DFunUnfolding case of+GHC.Core.Unfold.specUnfolding.++Note [Specialisation Must Preserve Sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a function: f :: forall a. Eq a => a -> blah@@ -1572,55 +1443,117 @@ Note [Specialising Calls] ~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have a function:+Suppose we have a function with a complicated type: - f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux- f = \x -> /\ a b c -> \d1 d2 bar -> rhs+ f :: forall a b c. Int -> Eq a => Show b => c -> Blah+ f @a @b @c i dEqA dShowA x = blah and suppose it is called at: - f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar+ f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 -This call is described as a 'CallInfo' whose 'ci_key' is+This call is described as a 'CallInfo' whose 'ci_key' is: - [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1- , SpecDict dFooT3, UnspecArg ]+ [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1+ , SpecDict ($dfShow dShowT2), UnspecArg ] -Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?+Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? Because we must specialise the function on type variables that appear free in its *dictionary* arguments; but not on type variables that do not appear in any dictionaries, i.e. are fully polymorphic. Because this call has dictionaries applied, we'd like to specialise the call on any type argument that appears free in those dictionaries.-In this case, those are (a ~ T1, c ~ T3).+In this case, those are [a :-> T1, b :-> T2]. -As a result, we'd like to generate a function:+We also need to substitute the dictionary binders with their+specialised dictionaries. The simplest substitution would be+[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates+work, since `$dfShow dShowT2` is a function application. Therefore, we+also want to *float the dictionary out* (via bindAuxiliaryDict),+creating a new dict binding - $sf :: Int -> forall b. Bar -> Qux- $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)+ dShow1 = $dfShow dShowT2 +and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1].++With the substitutions in hand, we can generate a specialised function:++ $sf :: forall c. Int -> c -> Blah+ $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)+ Note that the substitution is applied to the whole thing. This is convenient, but just slightly fragile. Notably: * There had better be no name clashes in a/b/c We must construct a rewrite rule: - RULE "SPEC f @T1 _ @T3"- forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).- f x @T1 @b @T3 d1' d2' = $sf x @b+ RULE "SPEC f @T1 @T2 _"+ forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).+ f @T1 @T2 @c i d1 d2 = $sf @c i -In the rule, d1' and d2' are just wildcards, not used in the RHS. Note-additionally that 'bar' isn't captured by this rule --- we bind only+In the rule, d1 and d2 are just wildcards, not used in the RHS. Note+additionally that 'x' isn't captured by this rule --- we bind only enough etas in order to capture all of the *specialised* arguments. -Finally, we must also construct the usage-details+Note [Drop dead args from specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, it’s possible some of the arguments may+actually be dead. For example, consider: - { d1' = dx1; d2' = dx2 }+ f :: forall a. () -> Show a => a -> String+ f x y = show y ++ "!" -where d1', d2' are cloned versions of d1,d2, with the type substitution-applied. These auxiliary bindings just avoid duplication of dx1, dx2.+We might generate the following CallInfo for `f @Int`: + [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg]++Normally we’d include both the x and y arguments in the+specialisation, since we’re not specialising on either of them. But+that’s silly, since x is actually unused! So we might as well drop it+in the specialisation:++ $sf :: Int -> String+ $sf y = show y ++ "!"++ {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}++This doesn’t save us much, since the arg would be removed later by+worker/wrapper, anyway, but it’s easy to do. Note, however, that we+only drop dead arguments if:++ 1. We don’t specialise on them.+ 2. They come before an argument we do specialise on.++Doing the latter would require eta-expanding the RULE, which could+make it match less often, so it’s not worth it. Doing the former could+be more useful --- it would stop us from generating pointless+specialisations --- but it’s more involved to implement and unclear if+it actually provides much benefit in practice.++Note [Zap occ info in rule binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we generate a specialisation RULE, we need to drop occurrence+info on the binders. If we don’t, things go wrong when we specialise a+function like++ f :: forall a. () -> Show a => a -> String+ f x y = show y ++ "!"++since we’ll generate a RULE like++ RULE "SPEC f @Int" forall x [Occ=Dead].+ f @Int x $dShow = $sf++and Core Lint complains, even though x only appears on the LHS (due to+Note [Drop dead args from specialisations]).++Why is that a Lint error? Because the arguments on the LHS of a rule+are syntactically expressions, not patterns, so Lint treats the+appearance of x as a use rather than a binding. Fortunately, the+solution is simple: we just make sure to zap the occ info before+using ids as wildcard binders in a rule.+ Note [Account for casts in binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1674,57 +1607,7 @@ What this means is that a SPEC rules from auto-specialisation in module M will be used in other modules only if M.hi has been read for some other reason, which is actually pretty likely.--} -bindAuxiliaryDicts- :: SpecEnv- -> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions- -> [DictId] -- A cloned dict-id for each dict arg- -> (SpecEnv, -- Substitute for all orig_dicts- [DictBind], -- Auxiliary dict bindings- [CoreExpr]) -- Witnessing expressions (all trivial)--- Bind any dictionary arguments to fresh names, to preserve sharing-bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })- orig_dict_ids call_ds inst_dict_ids- = (env', dx_binds, spec_dict_args)- where- (dx_binds, spec_dict_args) = go call_ds inst_dict_ids- env' = env { se_subst = subst `CoreSubst.extendSubstList`- (orig_dict_ids `zip` spec_dict_args)- `CoreSubst.extendInScopeList` dx_ids- , se_interesting = interesting `unionVarSet` interesting_dicts }-- dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]- interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds- , interestingDict env dx ]- -- See Note [Make the new dictionaries interesting]-- go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])- go [] _ = ([], [])- go (dx:dxs) (dx_id:dx_ids)- | exprIsTrivial dx = (dx_binds, dx : args)- | otherwise = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)- where- (dx_binds, args) = go dxs dx_ids- -- In the first case extend the substitution but not bindings;- -- in the latter extend the bindings but not the substitution.- -- For the former, note that we bind the *original* dict in the substitution,- -- overriding any d->dx_id binding put there by substBndrs- go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)--{--Note [Make the new dictionaries interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Important! We're going to substitute dx_id1 for d-and we want it to look "interesting", else we won't gather *any*-consequential calls. E.g.- f d = ...g d....-If we specialise f for a call (f (dfun dNumInt)), we'll get-a consequent call (g d') with an auxiliary definition- d' = df dNumInt-We want that consequent call to look interesting-- Note [From non-recursive to recursive] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Even in the non-recursive case, if any dict-binds depend on 'fn' we might@@ -2059,15 +1942,298 @@ don't get properly strictness analysed, for example. But it works well for examples involving specialisation, which is the dominant use of INLINABLE. See #4874.-+-} -************************************************************************+{- ********************************************************************* * *-\subsubsection{UsageDetails and suchlike}+ SpecArg, and specHeader * *-************************************************************************+********************************************************************* -}++-- | An argument that we might want to specialise.+-- See Note [Specialising Calls] for the nitty gritty details.+data SpecArg+ =+ -- | Type arguments that should be specialised, due to appearing+ -- free in the type of a 'SpecDict'.+ SpecType Type++ -- | Type arguments that should remain polymorphic.+ | UnspecType++ -- | Dictionaries that should be specialised. mkCallUDs ensures+ -- that only "interesting" dictionary arguments get a SpecDict;+ -- see Note [Interesting dictionary arguments]+ | SpecDict DictExpr++ -- | Value arguments that should not be specialised.+ | UnspecArg++instance Outputable SpecArg where+ ppr (SpecType t) = text "SpecType" <+> ppr t+ ppr UnspecType = text "UnspecType"+ ppr (SpecDict d) = text "SpecDict" <+> ppr d+ ppr UnspecArg = text "UnspecArg"++specArgFreeVars :: SpecArg -> VarSet+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty+specArgFreeVars (SpecDict dx) = exprFreeVars dx+specArgFreeVars UnspecType = emptyVarSet+specArgFreeVars UnspecArg = emptyVarSet++isSpecDict :: SpecArg -> Bool+isSpecDict (SpecDict {}) = True+isSpecDict _ = False++-- | Given binders from an original function 'f', and the 'SpecArg's+-- corresponding to its usage, compute everything necessary to build+-- a specialisation.+--+-- We will use the running example from Note [Specialising Calls]:+--+-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah+-- f @a @b @c i dEqA dShowA x = blah+--+-- Suppose we decide to specialise it at the following pattern:+--+-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg+-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ]+--+-- We'd eventually like to build the RULE+--+-- RULE "SPEC f @T1 @T2 _"+-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).+-- f @T1 @T2 @c i d1 d2 = $sf @c i+--+-- and the specialisation '$sf'+--+-- $sf :: forall c. Int -> c -> Blah+-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)+--+-- where dShow1 is a floated binding created by bindAuxiliaryDict.+--+-- The cases for 'specHeader' below are presented in the same order as this+-- running example. The result of 'specHeader' for this example is as follows:+--+-- ( -- Returned arguments+-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1]+-- , [x]+--+-- -- RULE helpers+-- , [c, i, d1, d2]+-- , [T1, T2, c, i, d1, d2]+--+-- -- Specialised function helpers+-- , [c, i, x]+-- , [dShow1 = $dfShow dShowT2]+-- , [T1, T2, c, i, dEqT1, dShow1]+-- )+specHeader+ :: SpecEnv+ -> [InBndr] -- The binders from the original function 'f'+ -> [SpecArg] -- From the CallInfo+ -> SpecM ( Bool -- True <=> some useful specialisation happened+ -- Not the same as any (isSpecDict args) because+ -- the args might be longer than bndrs++ -- Returned arguments+ , SpecEnv -- Substitution to apply to the body of 'f'+ , [OutBndr] -- Leftover binders from the original function 'f'+ -- that don’t have a corresponding SpecArg++ -- RULE helpers+ , [OutBndr] -- Binders for the RULE+ , [OutExpr] -- Args for the LHS of the rule++ -- Specialised function helpers+ , [OutBndr] -- Binders for $sf+ , [DictBind] -- Auxiliary dictionary bindings+ , [OutExpr] -- Specialised arguments for unfolding+ -- Same length as "args for LHS of rule"+ )++-- We want to specialise on type 'T1', and so we must construct a substitution+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding+-- details.+specHeader env (bndr : bndrs) (SpecType t : args)+ = do { let env' = extendTvSubstList env [(bndr, t)]+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+ <- specHeader env' bndrs args+ ; pure ( useful+ , env''+ , leftover_bndrs+ , rule_bs+ , Type t : rule_es+ , bs'+ , dx+ , Type t : spec_args+ )+ }++-- Next we have a type that we don't want to specialise. We need to perform+-- a substitution on it (in case the type refers to 'a'). Additionally, we need+-- to produce a binder, LHS argument and RHS argument for the resulting rule,+-- /and/ a binder for the specialised body.+specHeader env (bndr : bndrs) (UnspecType : args)+ = do { let (env', bndr') = substBndr env bndr+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+ <- specHeader env' bndrs args+ ; pure ( useful+ , env''+ , leftover_bndrs+ , bndr' : rule_bs+ , varToCoreExpr bndr' : rule_es+ , bndr' : bs'+ , dx+ , varToCoreExpr bndr' : spec_args+ )+ }++-- Next we want to specialise the 'Eq a' dict away. We need to construct+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for+-- the nitty-gritty), as a LHS rule and unfolding details.+specHeader env (bndr : bndrs) (SpecDict d : args)+ = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]+ ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d+ ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+ <- specHeader env' bndrs args+ ; pure ( True -- Ha! A useful specialisation!+ , env''+ , leftover_bndrs+ -- See Note [Evidence foralls]+ , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs+ , varToCoreExpr bndr' : rule_es+ , bs'+ , maybeToList dx_bind ++ dx+ , spec_dict : spec_args+ )+ }++-- Finally, we have the unspecialised argument 'i'. We need to produce+-- a binder, LHS and RHS argument for the RULE, and a binder for the+-- specialised body.+--+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so+-- this case must be here.+specHeader env (bndr : bndrs) (UnspecArg : args)+ = do { -- see Note [Zap occ info in rule binders]+ let (env', bndr') = substBndr env (zapIdOccInfo bndr)+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+ <- specHeader env' bndrs args+ ; pure ( useful+ , env''+ , leftover_bndrs+ , bndr' : rule_bs+ , varToCoreExpr bndr' : rule_es+ , if isDeadBinder bndr+ then bs' -- see Note [Drop dead args from specialisations]+ else bndr' : bs'+ , dx+ , varToCoreExpr bndr' : spec_args+ )+ }++-- If we run out of binders, stop immediately+-- See Note [Specialisation Must Preserve Sharing]+specHeader env [] _ = pure (False, env, [], [], [], [], [], [])++-- Return all remaining binders from the original function. These have the+-- invariant that they should all correspond to unspecialised arguments, so+-- it's safe to stop processing at this point.+specHeader env bndrs []+ = pure (False, env', bndrs', [], [], [], [], [])+ where+ (env', bndrs') = substBndrs env bndrs+++-- | Binds a dictionary argument to a fresh name, to preserve sharing+bindAuxiliaryDict+ :: SpecEnv+ -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression+ -> ( SpecEnv -- Substitute for orig_dict_id+ , Maybe DictBind -- Auxiliary dict binding, if any+ , OutExpr) -- Witnessing expression (always trivial)+bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })+ orig_dict_id fresh_dict_id dict_expr++ -- If the dictionary argument is trivial,+ -- don’t bother creating a new dict binding; just substitute+ | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr+ = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr+ `Core.extendInScope` dict_id+ -- See Note [Keep the old dictionaries interesting]+ , se_interesting = interesting `extendVarSet` dict_id }+ in (env', Nothing, dict_expr)++ | otherwise -- Non-trivial dictionary arg; make an auxiliary binding+ = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)+ env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)+ `Core.extendInScope` fresh_dict_id+ -- See Note [Make the new dictionaries interesting]+ , se_interesting = interesting `extendVarSet` fresh_dict_id }+ in (env', Just dict_bind, Var fresh_dict_id)++{-+Note [Make the new dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Important! We're going to substitute dx_id1 for d+and we want it to look "interesting", else we won't gather *any*+consequential calls. E.g.+ f d = ...g d....+If we specialise f for a call (f (dfun dNumInt)), we'll get+a consequent call (g d') with an auxiliary definition+ d' = df dNumInt+We want that consequent call to look interesting++Note [Keep the old dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In bindAuxiliaryDict, we don’t bother creating a new dict binding if+the dict expression is trivial. For example, if we have++ f = \ @m1 (d1 :: Monad m1) -> ...++and we specialize it at the pattern++ [SpecType IO, SpecArg $dMonadIO]++it would be silly to create a new binding for $dMonadIO; it’s already+a binding! So we just extend the substitution directly:++ m1 :-> IO+ d1 :-> $dMonadIO++But this creates a new subtlety: the dict expression might be a dict+binding we floated out while specializing another function. For+example, we might have++ d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict+ $sg = h @IO d2+ h = \ @m2 (d2 :: Applicative m2) -> ...++and end up specializing h at the following pattern:++ [SpecType IO, SpecArg d2]++When we created the d2 binding in the first place, we locally marked+it as interesting while specializing g as described above by+Note [Make the new dictionaries interesting]. But when we go to+specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the+knowledge that we should specialize on it.++To fix this, we have to explicitly add d2 *back* to the interesting+set. That way, it will still be considered interesting while+specializing the body of h. See !2913. -} ++{- *********************************************************************+* *+ UsageDetails and suchlike+* *+********************************************************************* -}+ data UsageDetails = MkUD { ud_binds :: !(Bag DictBind),@@ -2137,8 +2303,6 @@ data CallInfo = CI { ci_key :: [SpecArg] -- All arguments- , ci_arity :: Int -- The number of variables necessary to bind- -- all of the specialised arguments , ci_fvs :: VarSet -- Free vars of the ci_key -- call (including tyvars) -- [*not* include the main id itself, of course]@@ -2184,12 +2348,6 @@ callInfoFVs (CIS _ call_info) = foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info -computeArity :: [SpecArg] -> Int-computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg--callSpecArity :: [TyCoBinder] -> Int-callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder- getTheta :: [TyCoBinder] -> [PredType] getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) @@ -2200,13 +2358,9 @@ = MkUD {ud_binds = emptyBag, ud_calls = unitDVarEnv id $ CIS id $ unitBag (CI { ci_key = args -- used to be tys- , ci_arity = computeArity args , ci_fvs = call_fvs }) } where- tys = getSpecTypes args- dicts = getSpecDicts args- call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs- tys_fvs = tyCoVarsOfTypes tys+ call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args -- The type args (tys) are guaranteed to be part of the dictionary -- types, because they are just the constrained types, -- and the dictionary is therefore sure to be bound@@ -2225,43 +2379,48 @@ res = mkCallUDs' env f args mkCallUDs' env f args- | not (want_calls_for f) -- Imported from elsewhere- || null theta -- Not overloaded- = emptyUDs-- | not (all type_determines_value theta)- || not (computeArity ci_key <= idArity f)- || not (length dicts == length theta)- || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments]- -- See also Note [Specialisations already covered]+ | not (want_calls_for f) -- Imported from elsewhere+ || null ci_key -- No useful specialisation+ -- See also Note [Specialisations already covered] = -- pprTrace "mkCallUDs: discarding" _trace_doc- emptyUDs -- Not overloaded, or no specialisation wanted+ emptyUDs | otherwise = -- pprTrace "mkCallUDs: keeping" _trace_doc singleCall f ci_key where- _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]+ _trace_doc = vcat [ppr f, ppr args, ppr ci_key] pis = fst $ splitPiTys $ idType f- theta = getTheta pis- constrained_tyvars = tyCoVarsOfTypes theta+ constrained_tyvars = tyCoVarsOfTypes $ getTheta pis ci_key :: [SpecArg]- ci_key = fmap (\(t, a) ->- case t of- Named (binderVar -> tyVar)- | tyVar `elemVarSet` constrained_tyvars- -> case a of- Type ty -> SpecType ty- _ -> pprPanic "ci_key" $ ppr a- | otherwise- -> UnspecType- Anon InvisArg _ -> SpecDict a- Anon VisArg _ -> UnspecArg- ) $ zip pis args+ ci_key = dropWhileEndLE (not . isSpecDict) $+ zipWith mk_spec_arg args pis+ -- Drop trailing args until we get to a SpecDict+ -- In this way the RULE has as few args as possible,+ -- which broadens its applicability, since rules only+ -- fire when saturated - dicts = getSpecDicts ci_key+ mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg+ mk_spec_arg arg (Named bndr)+ | binderVar bndr `elemVarSet` constrained_tyvars+ = case arg of+ Type ty -> SpecType ty+ _ -> pprPanic "ci_key" $ ppr arg+ | otherwise = UnspecType + -- For "InvisArg", which are the type-class dictionaries,+ -- we decide on a case by case basis if we want to specialise+ -- on this argument; if so, SpecDict, if not UnspecArg+ mk_spec_arg arg (Anon InvisArg pred)+ | type_determines_value pred+ , interestingDict env arg -- Note [Interesting dictionary arguments]+ = SpecDict arg+ | otherwise = UnspecArg++ mk_spec_arg _ (Anon VisArg _)+ = UnspecArg+ want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f)) -- For imported things, we gather call instances if -- there is an unfolding that we could in principle specialise@@ -2280,12 +2439,18 @@ {- Note [Type determines value] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Only specialise if all overloading is on non-IP *class* params,-because these are the ones whose *type* determines their *value*. In-parrticular, with implicit params, the type args *don't* say what the-value of the implicit param is! See #7101+Only specialise on non-IP *class* params, because these are the ones+whose *type* determines their *value*. In particular, with implicit+params, the type args *don't* say what the value of the implicit param+is! See #7101. -However, consider+So we treat implicit params just like ordinary arguments for the+purposes of specialisation. Note that we still want to specialise+functions with implicit params if they have *other* dicts which are+class params; see #17930.++One apparent additional complexity involves type families. For+example, consider type family D (v::*->*) :: Constraint type instance D [] = () f :: D v => v Char -> Int@@ -2296,8 +2461,7 @@ So the question is: can an implicit parameter "hide inside" a type-family constraint like (D a). Well, no. We don't allow type instance D Maybe = ?x:Int-Hence the IrredPred case in type_determines_value.-See #7785.+Hence the IrredPred case in type_determines_value. See #7785. Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2593,20 +2757,20 @@ extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv extendTvSubstList env tv_binds- = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }+ = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } substTy :: SpecEnv -> Type -> Type-substTy env ty = CoreSubst.substTy (se_subst env) ty+substTy env ty = Core.substTy (se_subst env) ty substCo :: SpecEnv -> Coercion -> Coercion-substCo env co = CoreSubst.substCo (se_subst env) co+substCo env co = Core.substCo (se_subst env) co substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)-substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of+substBndr env bs = case Core.substBndr (se_subst env) bs of (subst', bs') -> (env { se_subst = subst' }, bs') substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])-substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of+substBndrs env bs = case Core.substBndrs (se_subst env) bs of (subst', bs') -> (env { se_subst = subst' }, bs') cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)@@ -2614,7 +2778,7 @@ -- Return the substitution to use for RHSs, and the one to use for the body cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) = do { us <- getUniqueSupplyM- ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr+ ; let (subst', bndr') = Core.cloneIdBndr subst us bndr interesting' | interestingDict env rhs = interesting `extendVarSet` bndr' | otherwise = interesting@@ -2623,7 +2787,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) = do { us <- getUniqueSupplyM- ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)+ ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs) env' = env { se_subst = subst' , se_interesting = interesting `extendVarSetList` [ v | (v,r) <- pairs, interestingDict env r ] }@@ -2633,9 +2797,9 @@ -- Make up completely fresh binders for the dictionaries -- Their bindings are going to float outwards newDictBndr env b = do { uniq <- getUniqueM- ; let n = idName b- ty' = substTy env (idType b)- ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }+ ; let n = idName b+ ty' = substTy env (idType b)+ ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) } newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id -- Give the new Id a similar occurrence name to the old one
compiler/typecheck/TcCanonical.hs view
@@ -761,13 +761,16 @@ ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs ; given_ev_vars <- mapM newEvVar (substTheta subst theta) - ; (w_id, ev_binds)- <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $+ ; (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 }@@ -1027,8 +1030,9 @@ empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1) - ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $- go skol_tvs empty_subst2 bndrs2+ ; (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" } }
compiler/typecheck/TcClassDcl.hs view
@@ -282,7 +282,7 @@ , sig_loc = getLoc (hsSigType hs_ty) } ; (ev_binds, (tc_bind, _))- <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $+ <- checkConstraints skol_info tyvars [this_dict] $ tcPolyCheck no_prag_fn local_dm_sig (L bind_loc lm_bind) @@ -303,6 +303,7 @@ | otherwise = pprPanic "tcDefMeth" (ppr sel_id) where+ skol_info = TyConSkol ClassFlavour (getName clas) sel_name = idName sel_id no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; -- they are all for meth_id
compiler/typecheck/TcErrors.hs view
@@ -209,10 +209,9 @@ ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) ; wanted <- zonkWC wanted -- Zonk to reveal all information- ; env0 <- tcInitTidyEnv -- If we are deferring we are going to need /all/ evidence around, -- including the evidence produced by unflattening (zonkWC)- ; let tidy_env = tidyFreeTyCoVars env0 free_tvs+ ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs free_tvs = tyCoVarsOfWCList wanted ; traceTc "reportUnsolved (after zonking):" $
compiler/typecheck/TcExpr.hs view
@@ -1080,10 +1080,6 @@ isHsValArg (HsTypeArg {}) = False isHsValArg (HsArgPar {}) = False -isHsTypeArg :: HsArg tm ty -> Bool-isHsTypeArg (HsTypeArg {}) = True-isHsTypeArg _ = False- isArgPar :: HsArg tm ty -> Bool isArgPar (HsArgPar {}) = True isArgPar (HsValArg {}) = False@@ -1218,14 +1214,6 @@ -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType) -- ^ (a wrapper for the function, the tc'd args, result type) tcArgs fun orig_fun_ty fun_orig orig_args herald- | fun_is_out_of_scope- , any isHsTypeArg orig_args- = failM -- See Note [VTA for out-of-scope functions]- -- We have /already/ emitted a CHoleCan constraint (in tcInferFun),- -- which will later cough up a "Variable not in scope error", so- -- we can simply fail now, avoiding a confusing error cascade-- | otherwise = go [] 1 orig_fun_ty orig_args where -- Don't count visible type arguments when determining how many arguments@@ -1247,6 +1235,10 @@ } go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args)+ | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]+ = go acc_args (n+1) fun_ty args++ | otherwise = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty -- wrap1 :: fun_ty "->" upsilon_ty ; case tcSplitForAllTy_maybe upsilon_ty of@@ -1337,17 +1329,23 @@ of type 'alpha' can't be applied to Bool. That's insane! And indeed users complain bitterly (#13834, #17150.) -The right error is the CHoleCan, which reports 'wurble' as out of-scope, and tries to give its type.+The right error is the CHoleCan, 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 acces to the function, so-we can check if it is a HsUnboundVar. If so, we simply fail-immediately. We've already inferred the type of the function,-so we'll /already/ have emitted a CHoleCan constraint; failing-preserves that constraint.+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 CHoleCan constraint;+failing preserves that constraint. -A mild shortcoming of this approach is that we thereby-don't typecheck any of the arguments, but so be it.+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcHsSyn.hs view
@@ -34,7 +34,7 @@ zonkTopBndrs, ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,- zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,+ zonkTyBndrs, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkTyVarOcc,@@ -325,20 +325,14 @@ where (tycovars, ids) = partition isTyCoVar vars -extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv-extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id+extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv+extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id = ze { ze_id_env = extendVarEnv id_env id id } -extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv-extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv+extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv+extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv = ze { ze_tv_env = extendVarEnv ty_env tv tv } -extendTyZonkEnvN :: ZonkEnv -> [(Name,TyVar)] -> ZonkEnv-extendTyZonkEnvN ze@(ZonkEnv { ze_tv_env = ty_env }) pairs- = ze { ze_tv_env = foldl add ty_env pairs }- where- add env (name, tv) = extendVarEnv_Directly env (getUnique name) tv- setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv setZonkType ze flexi = ze { ze_flexi = flexi } @@ -427,7 +421,7 @@ zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) zonkCoreBndrX env v | isId v = do { v' <- zonkIdBndr env v- ; return (extendIdZonkEnv1 env v', v') }+ ; return (extendIdZonkEnv env v', v') } | otherwise = zonkTyBndrX env v zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])@@ -442,12 +436,16 @@ zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) -- This guarantees to return a TyVar (not a TcTyVar) -- then we add it to the envt, so all occurrences are replaced+--+-- It does not clone: the new TyVar has the sane Name+-- as the old one. This important when zonking the+-- TyVarBndrs of a TyCon, whose Names may scope. zonkTyBndrX env tv = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) ) do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) -- Internal names tidy up better, for iface files. ; let tv' = mkTyVar (tyVarName tv) ki- ; return (extendTyZonkEnv1 env tv', tv') }+ ; return (extendTyZonkEnv env tv', tv') } zonkTyVarBinders :: [VarBndr TcTyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])@@ -464,22 +462,6 @@ = do { (env', tv') <- zonkTyBndrX env tv ; return (env', Bndr tv' vis) } -zonkRecTyVarBndrs :: [Name] -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])--- This rather specialised function is used in exactly one place.--- See Note [Tricky scoping in generaliseTcTyCon] in TcTyClsDecls.-zonkRecTyVarBndrs names tc_tvs- = initZonkEnv $ \ ze ->- fixM $ \ ~(_, rec_new_tvs) ->- do { let ze' = extendTyZonkEnvN ze $- zipWithLazy (\ tc_tv new_tv -> (getName tc_tv, new_tv))- tc_tvs rec_new_tvs- ; new_tvs <- zipWithM (zonk_one ze') names tc_tvs- ; return (ze', new_tvs) }- where- zonk_one ze name tc_tv- = do { ki <- zonkTcTypeToTypeX ze (tyVarKind tc_tv)- ; return (mkTyVar name ki) }- zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e @@ -1361,7 +1343,7 @@ zonk_pat env (VarPat x (dL->L l v)) = do { v' <- zonkIdBndr env v- ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }+ ; return (extendIdZonkEnv env v', VarPat x (cL l v')) } zonk_pat env (LazyPat x pat) = do { (env', pat') <- zonkPat env pat@@ -1373,7 +1355,7 @@ zonk_pat env (AsPat x (dL->L loc v) pat) = do { v' <- zonkIdBndr env v- ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat+ ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat ; return (env', AsPat x (cL loc v') pat') } zonk_pat env (ViewPat ty expr pat)@@ -1463,7 +1445,7 @@ ; lit1' <- zonkOverLit env2 lit1 ; lit2' <- zonkOverLit env2 lit2 ; ty' <- zonkTcTypeToTypeX env2 ty- ; return (extendIdZonkEnv1 env2 n',+ ; return (extendIdZonkEnv env2 n', NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') } zonk_pat env (CoPat x co_fn pat ty)@@ -1613,7 +1595,7 @@ = do scrut' <- zonkCoreExpr env scrut ty' <- zonkTcTypeToTypeX env ty b' <- zonkIdBndr env b- let env1 = extendIdZonkEnv1 env b'+ let env1 = extendIdZonkEnv env b' alts' <- mapM (zonkCoreAlt env1) alts return $ Case scrut' b' ty' alts' @@ -1627,7 +1609,7 @@ zonkCoreBind env (NonRec v e) = do v' <- zonkIdBndr env v e' <- zonkCoreExpr env e- let env1 = extendIdZonkEnv1 env v'+ let env1 = extendIdZonkEnv env v' return (env1, NonRec v' e') zonkCoreBind env (Rec pairs) = do (env1, pairs') <- fixM go
compiler/typecheck/TcHsType.hs view
@@ -725,6 +725,7 @@ m_telescope = Just (sep (map ppr hs_tvs)) ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted+ -- See Note [Skolem escape and forall-types] ; return (mkForAllTys bndrs ty') } @@ -913,6 +914,26 @@ See related Note [Wildcards in visible type application] here and Note [The wildcard story for types] in GHC.Hs.Types +Note [Skolem escape and forall-types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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+emitResidualTvConstraint 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. -} {- *********************************************************************@@ -2006,11 +2027,10 @@ -- -- mkAnonTyConBinder: see Note [No polymorphic recursion] - all_tv_prs = (kv_ns `zip` scoped_kvs) ++- (hsLTyVarNames hs_tvs `zip` tc_tvs)- -- NB: bindIplicitTKBndrs_Q_Tv makes /freshly-named/ unification- -- variables, hence the need to zip here. Ditto bindExplicit..- -- See TcMType Note [Unification variables need fresh Names]+ 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@@ -2036,98 +2056,102 @@ -> 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 ktvs kc_res_ki =- addTyConFlavCtxt name flav $- pushTcLevelM_ $- solveEqualities $ -- #16687- bind_implicit (hsq_ext ktvs) $ \implicit_tcv_prs -> 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 (hsq_explicit ktvs)-- -- 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)+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 - -- 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+ -- 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) - tcExtendNameTyVarEnv explicit_tv_prs $ do+ -- 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 - -- 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+ ; (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'.- m_res_ki <- kc_res_ki >>= \ctx_k ->- case ctx_k of- AnyKind -> return Nothing- _ -> Just <$> newExpectedKind ctx_k+ -- 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+ -- 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 - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.- invis_tcbs <- mapM invis_to_tcb invis_binders+ -- 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 - -- 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_tv_prs <- mapSndM zonkTcTyVarToTyVar implicit_tcv_prs+ ; 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- all_tv_prs = implicit_tv_prs ++ explicit_tv_prs- tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav+ ; 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+ ; traceTc "kcCheckDeclHeader_sig done:" $ vcat [ text "tyConName = " <+> ppr (tyConName tc) , text "kisig =" <+> debugPprType kisig , text "tyConKind =" <+> debugPprType (tyConKind tc)@@ -2135,7 +2159,7 @@ , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) , text "tyConResKind" <+> debugPprType (tyConResKind tc) ]- return tc+ ; return tc } where -- Consider this declaration: --@@ -2205,14 +2229,6 @@ MASSERT(null stv) return tcb - -- similar to: bindImplicitTKBndrs_Tv- bind_implicit :: [Name] -> ([(Name,TcTyVar)] -> TcM a) -> TcM a- bind_implicit tv_names thing_inside =- do { let new_tv name = do { tcv <- newFlexiKindedTyVarTyVar name- ; return (name, tcv) }- ; tcvs <- mapM new_tv tv_names- ; tcExtendNameTyVarEnv tcvs (thing_inside tcvs) }- -- 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 ()@@ -2242,6 +2258,8 @@ n_inst = n_sig_invis_bndrs - n_res_invis_bndrs in splitPiTysInvisibleN n_inst sig_ki +kcCheckDeclHeader_sig _ _ _ (XLHsQTyVars nec) _ = noExtCon nec+ -- A quantifier from a kind signature zipped with a user-written binder for it. data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn))@@ -2575,6 +2593,56 @@ * * ********************************************************************* -} +{- 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 --------------------------------------@@ -2582,10 +2650,12 @@ bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar-bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar 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@@ -2618,8 +2688,11 @@ newFlexiKindedTyVarTyVar :: Name -> TcM TyVar newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar- -- See Note [Unification variables need fresh Names] in TcMType +cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar+cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar+ -- See Note [Cloning for tyvar binders]+ -------------------------------------- -- Explicit binders --------------------------------------@@ -2630,7 +2703,9 @@ -> TcM ([TcTyVar], a) bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)-bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)+bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar)+ -- newSkolemTyVar: see Note [Non-cloning for tyvar binders]+ -- cloneTyVarTyVar: see Note [Cloning for tyvar binders] bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv :: ContextKind@@ -2640,7 +2715,9 @@ bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)+ -- See Note [Non-cloning for tyvar binders] + bindExplicitTKBndrsX :: (HsTyVarBndr GhcRn -> TcM TcTyVar) -> [LHsTyVarBndr GhcRn]@@ -2659,7 +2736,7 @@ -- 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 TcMType Note [Unification variables need fresh Names]+ -- See TcMType Note [Cloning for tyvar binders] ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ go hs_tvs ; return (tv:tvs, res) }@@ -2667,7 +2744,6 @@ ----------------- tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) -> HsTyVarBndr GhcRn -> TcM TcTyVar--- Returned TcTyVar has the same name; no cloning tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) = do { kind <- newMetaKindVar ; new_tv tv_nm kind }@@ -2810,10 +2886,13 @@ ; kindGeneralizeSome (const True) ty } -- | Specialized version of 'kindGeneralizeSome', but where no variables--- can be generalized. Use this variant when it is unknowable whether metavariables--- might later be constrained.--- See Note [Recipe for checking a signature] for why and where this--- function is needed.+-- 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@@ -3148,7 +3227,7 @@ ; return (wcs, wcx, theta, tau) } - -- No kind-generalization here:+ -- No kind-generalization here, but perhaps some promotion ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ mkSpecForAllTys explicit_tvs $ mkPhiTy theta $@@ -3159,6 +3238,14 @@ -- See Note [Extra-constraint holes in partial type signatures] ; emitNamedWildCardHoleConstraints wcs + -- Zonk, so that any nested foralls can "see" their occurrences+ -- See Note [Checking partial type signatures], in+ -- the bullet on Nested foralls.+ ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs+ ; explicit_tvs <- mapM zonkTcTyVarToTyVar explicit_tvs+ ; theta <- mapM zonkTcType theta+ ; tau <- zonkTcType tau+ -- We return a proper (Name,TyVar) environment, to be sure that -- we bring the right name into scope in the function body. -- Test case: partial-sigs/should_compile/LocalDefinitionBug@@ -3167,7 +3254,7 @@ -- 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 tuype to check+ -- here because we don't have a complete type to check ; traceTc "tcHsPartialSigType" (ppr tv_prs) ; return (wcs, wcx, tv_prs, theta, tau) }@@ -3189,13 +3276,32 @@ {- Note [Checking partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Recipe for checking a signature]+This Note is about tcHsPartialSigType. See also+Note [Recipe for checking a signature] -When we have a parital signature like- f,g :: forall a. a -> _+When we have a partial signature like+ f :: forall a. a -> _ we do the following -* In TcSigs.tcUserSigType we return a PartialSig, which (unlike+* 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 @@ -3203,18 +3309,34 @@ 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- becase they migh get instantiated completely differently. E.g.+ 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. -* Note that we don't 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.+* Nested foralls. Consider+ f :: forall b. (forall a. a -> _) -> b+ We do /not/ allow the "_" to be instantiated to 'a'; but we do+ (as before) allow it to be instantiated to the (top level) 'b'.+ Why not? Because suppose+ f x = (x True, x 'c')+ We must instantiate that (forall a. a -> _) when typechecking+ f's body, so we must know precisely where all the a's are; they+ must not be hidden under (filled-in) unification variables! - Nor, for the same reason, do we push a level in tcHsPartialSigType.+ We achieve this in the usual way: we push a level at a forall,+ so now the unification variable for the "_" can't unify with+ 'a'.++* Just as for ordinary signatures, we must 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 [Extra-constraint holes in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcInstDcls.hs view
@@ -71,6 +71,7 @@ import Control.Monad import Maybes+import Data.Tuple ( swap ) import Data.List( mapAccumL ) @@ -453,7 +454,7 @@ ; return ([], [fam_inst], []) } tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))- = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl)+ = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl) ; return ([], [fam_inst], maybeToList m_deriv_info) } tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))@@ -478,6 +479,9 @@ ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars ; let tv_skol_prs = [ (tyVarName tv, skol_tv) | (tv, skol_tv) <- tyvars `zip` skol_tvs ]+ -- Map from the skolemized Names to the original Names.+ -- 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 visible_skol_tvs = drop n_inferred skol_tvs@@ -492,7 +496,7 @@ mb_info = InClsInst { ai_class = clas , ai_tyvars = visible_skol_tvs , ai_inst_env = mini_env }- ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts+ ; df_stuff <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info) ats -- Check for missing associated types and build them@@ -631,10 +635,16 @@ than type family instances -} -tcDataFamInstDecl :: AssocInstInfo- -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)+tcDataFamInstDecl ::+ AssocInstInfo+ -> TyVarEnv Name -- If this is an associated data family instance, maps the+ -- parent class's skolemized type variables to their+ -- original Names. If this is a non-associated instance,+ -- this will be empty.+ -- See Note [Associated data family instances and di_scoped_tvs].+ -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo) -- "newtype instance" and "data instance"-tcDataFamInstDecl mb_clsinfo+tcDataFamInstDecl mb_clsinfo tv_skol_env (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_bndrs = mb_bndrs@@ -744,11 +754,12 @@ ; checkValidCoAxBranch fam_tc ax_branch ; checkValidTyCon rep_tc - ; let m_deriv_info = case derivs of+ ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc)+ m_deriv_info = case derivs of L _ [] -> Nothing L _ preds -> Just $ DerivInfo { di_rep_tc = rep_tc- , di_scoped_tvs = mkTyVarNamePairs (tyConTyVars rep_tc)+ , di_scoped_tvs = scoped_tvs , di_clauses = preds , di_ctxt = tcMkDataFamInstCtxt decl } @@ -779,7 +790,47 @@ = go pats (Bndr tv tcb_vis : etad_tvs) go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs) -tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"+ -- Create a Name-TyVar mapping to bring into scope when typechecking any+ -- deriving clauses this data family instance may have.+ -- See Note [Associated data family instances and di_scoped_tvs].+ mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)+ mk_deriv_info_scoped_tv_pr tv =+ let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv+ in (n, tv)++tcDataFamInstDecl _ _ decl+ = pprPanic "tcDataFamInstDecl: This can't happen" (ppr decl)++{-+Note [Associated data family instances and di_scoped_tvs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some care is required to implement `deriving` correctly for associated data+family instances. Consider this example from #18055:++ class C a where+ data D a++ class X a b++ instance C (Maybe a) where+ data D (Maybe a) deriving (X a)++When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a`+from the instance header is brought into scope. This is the role of+di_scoped_tvs, which maps from the original, renamed `a` to the skolemized,+typechecked `a`. When typechecking the `deriving` clause, this mapping will be+consulted when looking up the `a` in `X a`.++A naïve attempt at creating the di_scoped_tvs is to simply reuse the+tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only+half correct, however. We do want the typechecked `a`'s Name in the /range/+of the mapping, but we do not want it in the /domain/ of the mapping.+To ensure that the original `a`'s Name ends up in the domain, we consult a+TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the+typechecked `a`'s Name to the original `a`'s Name. In the even that+tcDataFamInstDecl is processing a non-associated data family instance, this+TyVarEnv will simply be empty, and there is nothing to worry about.+-} ----------------------- tcDataFamInstHeader
compiler/typecheck/TcMType.hs view
@@ -54,7 +54,8 @@ -- Instantiation newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarTyVars, newMetaTyVarTyVarX,- newTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,+ newTyVarTyVar, cloneTyVarTyVar,+ newPatSigTyVar, newSkolemTyVar, newWildCardX, tcInstType, tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,@@ -703,30 +704,6 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we give a unification variable a System Name, which influences the way it is tidied; see TypeRep.tidyTyVarBndr.--Note [Unification variables need fresh Names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we allocate a unification variable (MetaTyVar) we give-it a fresh name. #16221 is a very tricky case that illustrates-why this is important:-- data SameKind :: k -> k -> *- data T0 a = forall k2 (b :: k2). MkT0 (SameKind a b) !Int--When kind-checking T0, we give (a :: kappa1). Then, in kcConDecl-we allocate a unification variable kappa2 for k2, and then we-end up unifying kappa1 := kappa2 (because of the (SameKind a b).--Now we generalise over kappa2; but if kappa2's Name is k2,-we'll end up giving T0 the kind forall k2. k2 -> *. Nothing-directly wrong with that but when we typecheck the data constrautor-we end up giving it the type- MkT0 :: forall k1 (a :: k1) k2 (b :: k2).- SameKind @k2 a b -> Int -> T0 @{k2} a-which is bogus. The result type should be T0 @{k1} a.--And there no reason /not/ to clone the Name when making a-unification variable. So that's what we do. -} newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar@@ -751,9 +728,18 @@ newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv]--- See Note [Unification variables need fresh Names]+-- Does not clone a fresh unique newTyVarTyVar name kind = do { details <- newMetaDetails TyVarTv+ ; let tyvar = mkTcTyVar name kind details+ ; traceTc "newTyVarTyVar" (ppr tyvar)+ ; return tyvar }++cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar+-- See Note [TyVarTv]+-- Clones a fresh unique+cloneTyVarTyVar name kind+ = do { details <- newMetaDetails TyVarTv ; uniq <- newUnique ; let name' = name `setNameUnique` uniq tyvar = mkTcTyVar name' kind details@@ -761,7 +747,7 @@ -- We want to keep the original more user-friendly Name -- In practical terms that means that in error messages, -- when the Name is tidied we get 'a' rather than 'a0'- ; traceTc "newTyVarTyVar" (ppr tyvar)+ ; traceTc "cloneTyVarTyVar" (ppr tyvar) ; return tyvar } newPatSigTyVar :: Name -> Kind -> TcM TcTyVar@@ -1295,11 +1281,11 @@ go dv (CoercionTy co) = collect_cand_qtvs_co bound dv co go dv (TyVarTy tv)- | is_bound tv = return dv- | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv- ; case m_contents of- Just ind_ty -> go dv ind_ty- Nothing -> go_tv dv tv }+ | is_bound tv = return dv+ | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv+ ; case m_contents of+ Just ind_ty -> go dv ind_ty+ Nothing -> go_tv dv tv } go dv (ForAllTy (Bndr tv _) ty) = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)@@ -1734,16 +1720,17 @@ skolemiseUnboundMetaTyVar tv = ASSERT2( isMetaTyVar tv, ppr tv ) do { when debugIsOn (check_empty tv)- ; span <- getSrcSpanM -- Get the location from "here"+ ; here <- getSrcSpanM -- Get the location from "here" -- ie where we are generalising ; kind <- zonkTcType (tyVarKind tv)- ; let uniq = getUnique tv- -- NB: Use same Unique as original tyvar. This is- -- convenient in reading dumps, but is otherwise inessential.-- tv_name = getOccName tv- final_name = mkInternalName uniq tv_name span- final_tv = mkTcTyVar final_name kind details+ ; let tv_name = tyVarName tv+ -- See Note [Skolemising and identity]+ final_name | isSystemName tv_name+ = mkInternalName (nameUnique tv_name)+ (nameOccName tv_name) here+ | otherwise+ = tv_name+ final_tv = mkTcTyVar final_name kind details ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv)@@ -1856,9 +1843,29 @@ variable now floating around in the simplifier, which in many places assumes to only see proper TcTyVars. -We can avoid this problem by zonking with a skolem. The skolem is rigid-(which we require for a quantified variable), but is still a TcTyVar that the-simplifier knows how to deal with.+We can avoid this problem by zonking with a skolem TcTyVar. The+skolem is rigid (which we require for a quantified variable), but is+still a TcTyVar that the simplifier knows how to deal with.++Note [Skolemising and identity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some places, we make a TyVarTv for a binder. E.g.+ class C a where ...+As Note [Inferring kinds for type declarations] discusses,+we make a TyVarTv for 'a'. Later we skolemise it, and we'd+like to retain its identity, location info etc. (If we don't+retain its identity we'll have to do some pointless swizzling;+see TcTyClsDecls.swizzleTcTyConBndrs. If we retain its identity+but not its location we'll lose the detailed binding site info.++Conclusion: use the Name of the TyVarTv. But we don't want+to do that when skolemising random unification variables;+there the location we want is the skolemisation site.++Fortunately we can tell the difference: random unification+variables have System Names. That's why final_name is+set based on the isSystemName test.+ Note [Silly Type Synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/typecheck/TcSMonad.hs view
@@ -7,17 +7,17 @@ WorkList(..), isEmptyWorkList, emptyWorkList, extendWorkListNonEq, extendWorkListCt, extendWorkListCts, extendWorkListEq, extendWorkListFunEq,- appendWorkList, extendWorkListImplic,+ appendWorkList, selectNextWorkItem, workListSize, workListWantedCount,- getWorkList, updWorkListTcS,+ getWorkList, updWorkListTcS, pushLevelNoWorkList, -- The TcS monad TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, failTcS, warnTcS, addErrTcS, runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS,- checkConstraintsTcS, checkTvConstraintsTcS,+ emitImplicationTcS, emitTvImplicationTcS, runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, matchGlobalInst, TcM.ClsInstResult(..),@@ -316,8 +316,8 @@ extendWorkListDeriveds evs wl = extendWorkListCts (map mkNonCanonical evs) wl -extendWorkListImplic :: Bag Implication -> WorkList -> WorkList-extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }+extendWorkListImplic :: Implication -> WorkList -> WorkList+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic@@ -2892,85 +2892,48 @@ ; return res } -checkTvConstraintsTcS :: SkolemInfo- -> [TcTyVar] -- Skolems- -> TcS (result, Cts)- -> TcS result--- Just like TcUnify.checkTvConstraints, but--- - In the TcS monnad--- - The thing-inside should not put things in the work-list--- Instead, it returns the Wanted constraints it needs--- - No 'givens', and no TcEvBinds; this is type-level constraints only-checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)- = TcS $ \ tcs_env ->- do { let wl_panic = pprPanic "TcSMonad.buildImplication" $- ppr skol_info $$ ppr skol_tvs- -- This panic checks that the thing-inside- -- does not emit any work-list constraints- new_tcs_env = tcs_env { tcs_worklist = wl_panic }+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 }) } - ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $- thing_inside new_tcs_env+ ; emitImplication imp+ ; return (TcEvBinds (ic_binds imp)) } - ; unless (null wanteds) $- do { ev_binds_var <- TcM.newNoTcEvBinds- ; imp <- TcM.newImplication- ; let wc = emptyWC { wc_simple = wanteds }- imp' = imp { ic_tclvl = new_tclvl- , ic_skols = skol_tvs- , ic_wanted = wc- , ic_binds = ev_binds_var- , ic_info = skol_info }+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 }) } - -- Add the implication to the work-list- ; TcM.updTcRef (tcs_worklist tcs_env)- (extendWorkListImplic (unitBag imp')) }+ ; emitImplication imp } - ; return res } -checkConstraintsTcS :: SkolemInfo- -> [TcTyVar] -- Skolems- -> [EvVar] -- Givens- -> TcS (result, Cts)- -> TcS (result, TcEvBinds)--- Just like checkConstraintsTcS, but--- - In the TcS monnad--- - The thing-inside should not put things in the work-list--- Instead, it returns the Wanted constraints it needs--- - I did not bother to put in the fast-path for--- empty-skols/empty-givens, or for empty-wanteds, because--- this function is used only for "quantified constraints" in--- with both tests are pretty much guaranteed to fail-checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)- = TcS $ \ tcs_env ->- do { let wl_panic = pprPanic "TcSMonad.buildImplication" $- ppr skol_info $$ ppr skol_tvs- -- This panic checks that the thing-inside- -- does not emit any work-list constraints- new_tcs_env = tcs_env { tcs_worklist = wl_panic }-- ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $- thing_inside new_tcs_env-- ; ev_binds_var <- TcM.newTcEvBinds- ; imp <- TcM.newImplication- ; let wc = emptyWC { wc_simple = wanteds }- imp' = imp { ic_tclvl = new_tclvl- , ic_skols = skol_tvs- , ic_given = given- , ic_wanted = wc- , ic_binds = ev_binds_var- , ic_info = skol_info }-- -- Add the implication to the work-list- ; TcM.updTcRef (tcs_worklist tcs_env)- (extendWorkListImplic (unitBag imp'))-- ; return (res, TcEvBinds ev_binds_var) }--{--Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's really quite important that nestTcS does not discard the solved dictionaries from the thing_inside. Consider@@ -3004,6 +2967,23 @@ ; 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 "TcSMonad.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@@ -3020,6 +3000,10 @@ 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)
compiler/typecheck/TcSigs.hs view
@@ -638,7 +638,6 @@ This wrapper is put in the TcSpecPrag, in the ABExport record of the AbsBinds. - f :: (Eq a, Ix b) => a -> b -> Bool {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} f = <poly_rhs>@@ -666,8 +665,6 @@ * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it can fully specialise it. -- From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE: f_spec :: Int -> b -> Int@@ -706,14 +703,14 @@ So we simply do this: - Generate a constraint to check that the specialised type (after- skolemiseation) is equal to the instantiated function type.+ skolemisation) is equal to the instantiated function type. - But *discard* the evidence (coercion) for that constraint, so that we ultimately generate the simpler code f_spec :: Int -> F Int f_spec = <f rhs> Int dNumInt RULE: forall d. f Int d = f_spec- You can see this discarding happening in+ You can see this discarding happening in tcSpecPrag 3. Note that the HsWrapper can transform *any* function with the right type prefix
compiler/typecheck/TcSplice.hs view
@@ -1645,7 +1645,7 @@ -- constructors can be declared infix. -- See Note [Infix GADT constructors] in TcTyClsDecls. | dataConIsInfix dc && not isGadtDataCon ->- ASSERT( arg_tys `lengthIs` 2 ) do+ ASSERT( r_arg_tys `lengthIs` 2 ) do { let [r_a1, r_a2] = r_arg_tys [s1, s2] = dcdBangs ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }@@ -1664,7 +1664,7 @@ { cxt <- reifyCxt theta' ; ex_tvs'' <- reifyTyVars ex_tvs' ; return (TH.ForallC ex_tvs'' cxt main_con) }- ; ASSERT( arg_tys `equalLength` dcdBangs )+ ; ASSERT( r_arg_tys `equalLength` dcdBangs ) ret_con } {-
compiler/typecheck/TcTyClsDecls.hs view
@@ -6,10 +6,12 @@ TcTyClsDecls: Typecheck type and class declarations -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}+{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module TcTyClsDecls ( tcTyAndClassDecls, @@ -37,7 +39,7 @@ import TcClassDcl import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) import TcDeriv (DerivInfo(..))-import TcUnify ( unifyKind )+import TcUnify ( unifyKind, checkTvConstraints ) import TcHsType import ClsInst( AssocInstInfo(..) ) import TcMType@@ -78,11 +80,12 @@ import Control.Monad import Data.Foldable import Data.Function ( on )+import Data.Functor.Identity import Data.List import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set-+import Data.Tuple( swap ) {- ************************************************************************@@ -316,8 +319,8 @@ you can always specify a CUSK directly to make this work out. See tc269 for an example. -Note [Skip decls with CUSKs in kcLTyClDecl]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CUSKs and PolyKinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T (a :: *) = MkT (S a) -- Has CUSK@@ -431,6 +434,108 @@ 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.@@ -454,15 +559,15 @@ B :-> TcTyCon <initial kind> (thereby overriding the B :-> TyConPE binding) and do kcLTyClDecl on each decl to get equality constraints on- all those inital kinds+ all those initial kinds - - Generalise the inital kind, making a poly-kinded TcTyCon+ - 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 sitll be signalled as+ so that (in our example) a use of MkB will still be signalled as an error. 4. Typecheck the decls.@@ -530,7 +635,8 @@ -- 3. Generalise the inferred kinds -- See Note [Kind checking for type and class decls] - ; cusks_enabled <- xoptM LangExt.CUSKs+ ; 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@@ -559,10 +665,8 @@ -- NB: the environment extension overrides the tycon -- promotion-errors bindings -- See Note [Type environment evolution]- ; poly_kinds <- xoptM LangExt.PolyKinds ; tcExtendKindEnvWithTyCons mono_tcs $- mapM_ kcLTyClDecl (if poly_kinds then kindless_decls else decls)- -- See Note [Skip decls with CUSKs in kcLTyClDecl]+ mapM_ kcLTyClDecl kindless_decls ; return mono_tcs } @@ -570,107 +674,227 @@ -- Finally, go through each tycon and give it its final kind, -- with all the required, specified, and inferred variables -- in order.- ; generalized_tcs <- mapAndReportM generaliseTcTyCon inferred_tcs+ ; 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) -generaliseTcTyCon :: TcTyCon -> TcM TcTyCon-generaliseTcTyCon tc- -- See Note [Required, Specified, and Inferred for types]- = setSrcSpan (getSrcSpan tc) $- addTyConCtxt tc $- do { let tc_name = tyConName tc- tc_res_kind = tyConResKind tc- spec_req_prs = tcTyConScopedTyVars 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 - (spec_req_names, spec_req_tvs) = unzip spec_req_prs- -- NB: spec_req_tvs includes both Specified and Required- -- Running example in Note [Inferring kinds for type declarations]- -- spec_req_prs = [ ("k1",kk1), ("a", (aa::kk1))- -- , ("k2",kk2), ("x", (xx::kk2))]- -- where "k1" dnotes the Name k1, and kk1, aa, etc are MetaTyVars,- -- specifically TyVarTvs+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 - -- Step 0: zonk and skolemise the Specified and Required binders- -- It's essential that they are skolems, not MetaTyVars,- -- for Step 3 to work right- ; spec_req_tvs <- mapM zonkAndSkolemise spec_req_tvs- -- Running example, where kk1 := kk2, so we get- -- [kk2,kk2]+ -- Extract the specified/required binders and skolemise them+ ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl - -- Step 1: 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- ; checkDuplicateTyConBinders spec_req_names spec_req_tvs+ -- 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 TcHsType+ = 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++ swizzle_ty ty = runIdentity (mapType swizzleMapper () 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 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- -- NB: candidateQTyVarsOfKinds zonks as it goes ; dvs1 <- candidateQTyVarsOfKinds $- (tc_res_kind : map tyVarKind spec_req_tvs)+ (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 - -- Step 3a: rename all the Specified and Required tyvars back to- -- TyVars with their oroginal user-specified name. Example- -- class C a_r23 where ....- -- By this point we have scoped_prs = [(a_r23, a_r89[TyVarTv])]- -- We return with the TyVar a_r23[TyVar],- -- and ze mapping a_r89 :-> a_r23[TyVar]- ; traceTc "generaliseTcTyCon: before zonkRec"- (vcat [ text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+ ; 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 ])- ; (ze, final_spec_req_tvs) <- zonkRecTyVarBndrs spec_req_names spec_req_tvs- -- So ze maps from the tyvars that have ended up - -- Step 3b: Apply that mapping to the other variables- -- (remember they all started as TyVarTvs).- -- They have been skolemised by quantifyTyVars.- ; (ze, inferred) <- zonkTyBndrsX ze inferred- ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind+ -- 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 "ze =" <+> ppr ze- , text "spec_req_prs =" <+> ppr spec_req_prs , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs- , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs ]-- -- Step 4: Find the Specified and Inferred 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 TyCon- ; let n_spec = length final_spec_req_tvs - tyConArity tc- (spec_tvs, req_tvs) = splitAt n_spec final_spec_req_tvs- specified = scopedSort spec_tvs- -- NB: maintain the L-R order of scoped_tvs+ , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs+ , text "req_tvs =" <+> ppr req_tvs+ , text "zonk-env =" <+> ppr ze ] - -- Step 5: Make the TyConBinders.- to_user tv = lookupTyVarOcc ze tv `orElse` tv- dep_fv_set = mapVarSet to_user (candidateKindVars dvs1)+ -- Step 4: Make the TyConBinders.+ ; let dep_fv_set = candidateKindVars dvs1 inferred_tcbs = mkNamedTyConBinders Inferred inferred- specified_tcbs = mkNamedTyConBinders Specified specified+ specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs - -- Step 6: Assemble the final list.+ -- Step 5: Assemble the final list. final_tcbs = concat [ inferred_tcbs , specified_tcbs , required_tcbs ] - -- Step 7: Make the result TcTyCon- tycon = mkTcTyCon tc_name final_tcbs tc_res_kind- (mkTyVarNamePairs final_spec_req_tvs)+ -- 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) @@ -678,32 +902,18 @@ vcat [ text "tycon =" <+> ppr tc , text "tc_res_kind =" <+> ppr tc_res_kind , text "dep_fv_set =" <+> ppr dep_fv_set- , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs- , text "inferred =" <+> pprTyVars inferred- , text "specified =" <+> pprTyVars specified+ , 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 8: Check for validity.+ -- 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 } -checkDuplicateTyConBinders :: [Name] -> [TcTyVar] -> TcM ()-checkDuplicateTyConBinders spec_req_names spec_req_tvs- | null dups = return ()- | otherwise = mapM_ report_dup dups >> failM- where- dups :: [(Name,Name)]- dups = findDupTyVarTvs $ spec_req_names `zip` spec_req_tvs-- report_dup (n1, n2)- = setSrcSpan (getSrcSpan n2) $- addErrTc (text "Couldn't match" <+> quotes (ppr n1)- <+> text "with" <+> quotes (ppr n2))- {- Note [Required, Specified, and Inferred for types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each forall'd type variable in a type or kind is one of@@ -838,7 +1048,7 @@ * Step 1: inferInitialKinds, and in particular kcInferDeclHeader. Make a unification variable for each of the Required and Specified- type varialbes in the header.+ type variables in the header. Record the connection between the Names the user wrote and the fresh unification variables in the tcTyConScopedTyVars field@@ -863,7 +1073,7 @@ S :: kk3 -> * -> kk4 -> * * Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and- T, with these monomophic kinds. Now kind-check the declarations,+ 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. @@ -974,8 +1184,40 @@ 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. -}+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+TcHsType 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@@ -996,16 +1238,16 @@ mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) = unitNameEnv nm (APromotionErr ClassPE) `plusNameEnv`- mkNameEnv [ (name, APromotionErr TyConPE)- | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]+ mkNameEnv [ (familyDeclName at, APromotionErr TyConPE)+ | L _ at <- ats ] -mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)+mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE)- | (dL->L _ con') <- cons- , (dL->L _ con) <- getConNames con' ]+ | L _ con' <- cons+ , L _ con <- getConNames con' ] mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE)@@ -1054,7 +1296,7 @@ -- -- No family instances are passed to checkInitialKinds/inferInitialKinds getInitialKind strategy- (ClassDecl { tcdLName = dL->L _ name+ (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $@@ -1072,7 +1314,7 @@ InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy- (DataDecl { tcdLName = dL->L _ name+ (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig , dd_ND = new_or_data } })@@ -1105,7 +1347,7 @@ ; return [tc] } getInitialKind strategy- (SynDecl { tcdLName = dL->L _ name+ (SynDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdRhs = rhs }) = do { let ctxt = TySynKindCtxt name@@ -1124,14 +1366,14 @@ -> FamilyDecl GhcRn -> TcM TcTyCon get_fam_decl_initial_kind mb_parent_tycon- FamilyDecl { fdLName = (dL->L _ name)+ FamilyDecl { fdLName = L _ name , fdTyVars = ktvs- , fdResultSig = (dL->L _ resultSig)+ , fdResultSig = L _ resultSig , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of- KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki- TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+ 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@@ -1258,30 +1500,32 @@ ------------------------------------------------------------------------ kcLTyClDecl :: LTyClDecl GhcRn -> TcM () -- See Note [Kind checking for type and class decls]-kcLTyClDecl (dL->L loc decl)+ -- Called only for declarations without a signature (no CUSKs or SAKs here)+kcLTyClDecl (L loc decl) = setSrcSpan loc $- tcAddDeclCtxt decl $- do { traceTc "kcTyClDecl {" (ppr tc_name)- ; kcTyClDecl decl+ do { tycon <- kcLookupTcTyCon 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 = tyClDeclLName decl+ tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcM ()+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 = (dL->L _ name)- , tcdDataDefn = defn })- | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)- , dd_ctxt = (dL->L _ [])+kcTyClDecl (DataDecl { tcdLName = (L _ name)+ , tcdDataDefn = defn }) tyCon+ | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _)+ , dd_ctxt = (L _ []) , dd_ND = new_or_data } <- defn- = do { tyCon <- kcLookupTcTyCon name- -- See Note [Implementation of UnliftedNewtypes] STEP 2- ; kcConDecls new_or_data (tyConResKind tyCon) cons- }+ = -- 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)@@ -1294,18 +1538,17 @@ , dd_ND = new_or_data } <- defn = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt- ; tyCon <- kcLookupTcTyCon name ; kcConDecls new_or_data (tyConResKind tyCon) cons } -kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })+kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon = bindTyClTyVars name $ \ _ res_kind -> discardResult $ tcCheckLHsType rhs res_kind -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)- , tcdCtxt = ctxt, tcdSigs = sigs })+kcTyClDecl (ClassDecl { tcdLName = L _ name+ , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon = bindTyClTyVars name $ \ _ _ -> do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM_ kc_sig) sigs }@@ -1315,18 +1558,15 @@ skol_info = TyConSkol ClassFlavour name -kcTyClDecl (FamDecl _ (FamilyDecl { fdLName = (dL->L _ fam_tc_name)- , fdInfo = fd_info }))+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) ->- do { fam_tc <- kcLookupTcTyCon fam_tc_name- ; mapM_ (kcTyFamInstEqn fam_tc) eqns }+ ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns _ -> return ()-kcTyClDecl (FamDecl _ (XFamilyDecl nec)) = noExtCon nec-kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec-kcTyClDecl (XTyClDecl nec) = noExtCon nec+kcTyClDecl (FamDecl _ (XFamilyDecl nec)) _ = noExtCon nec+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec+kcTyClDecl (XTyClDecl nec) _ = noExtCon nec ------------------- @@ -1439,7 +1679,7 @@ 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" metions k? This is incredibly+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 ... @@ -1686,19 +1926,19 @@ There's also a change in the renamer: -* In RnSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means+* 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 neccessary to make coerce work on+For completeness, it was also necessary to make coerce work on unlifted types, resolving #13595. -} tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])-tcTyClDecl roles_info (dL->L loc decl)+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)@@ -1735,24 +1975,21 @@ -- "type" synonym declaration tcTyClDecl1 _parent roles_info- (SynDecl { tcdLName = (dL->L _ tc_name)+ (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = ASSERT( isNothing _parent ) fmap noDerivInfos $- bindTyClTyVars tc_name $ \ binders res_kind ->- tcTySynRhs roles_info tc_name binders res_kind rhs+ tcTySynRhs roles_info tc_name rhs -- "data/newtype" declaration tcTyClDecl1 _parent roles_info- decl@(DataDecl { tcdLName = (dL->L _ tc_name)+ decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = ASSERT( isNothing _parent )- bindTyClTyVars tc_name $ \ tycon_binders res_kind ->- tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name- tycon_binders res_kind defn+ tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn tcTyClDecl1 _parent roles_info- (ClassDecl { tcdLName = (dL->L _ class_name)+ (ClassDecl { tcdLName = L _ class_name , tcdCtxt = hs_ctxt , tcdMeths = meths , tcdFDs = fundeps@@ -1789,6 +2026,9 @@ ; (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@@ -1821,6 +2061,7 @@ 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') }@@ -1853,10 +2094,10 @@ ; mapM tc_at ats } where at_def_tycon :: LTyFamDefltDecl GhcRn -> Name- at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn+ at_def_tycon = tyFamInstDeclName . unLoc at_fam_name :: LFamilyDecl GhcRn -> Name- at_fam_name (dL->L _ decl) = unLoc (fdLName decl)+ at_fam_name = familyDeclName . unLoc at_names = mkNameSet (map at_fam_name ats) @@ -1885,7 +2126,7 @@ <+> ppr (tyFamInstDeclName (unLoc d1))) tcDefaultAssocDecl fam_tc- [dL->L loc (TyFamInstDecl { tfid_eqn =+ [L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_ext = imp_vars , hsib_body = FamEqn { feqn_tycon = L _ tc_name , feqn_bndrs = mb_expl_bndrs@@ -1983,10 +2224,11 @@ suggestion :: SDoc suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables"-tcDefaultAssocDecl _ [_]- = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884 +tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x+tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x + {- Note [Type-checking default assoc decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this default declaration for an associated type@@ -2052,8 +2294,8 @@ tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info- , fdLName = tc_lname@(dL->L _ tc_name)- , fdResultSig = (dL->L _ sig)+ , fdLName = tc_lname@(L _ tc_name)+ , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info = bindTyClTyVars tc_name $ \ binders res_kind -> do@@ -2144,7 +2386,9 @@ -- overlap done by dropDominatedAxioms ; return fam_tc } } +#if __GLASGOW_HASKELL__ <= 810 | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker+#endif tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec -- | Maybe return a list of Bools that say whether a type family was declared@@ -2176,7 +2420,7 @@ -- 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 (dL->L loc (InjectivityAnn _ lInjNames)))+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags@@ -2192,12 +2436,11 @@ , ppr inj_ktvs, ppr inj_bools ]) ; return $ Injective inj_bools } -tcTySynRhs :: RolesInfo- -> Name- -> [TyConBinder] -> Kind+tcTySynRhs :: RolesInfo -> Name -> LHsType GhcRn -> TcM TyCon-tcTySynRhs roles_info tc_name binders res_kind hs_ty- = do { env <- getLclEnv+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 $@@ -2207,27 +2450,29 @@ tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty ; return tycon } -tcDataDefn :: SDoc- -> RolesInfo -> Name- -> [TyConBinder] -> Kind+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 tycon_binders res_kind+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 })- = do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons+ = bindTyClTyVars tc_name $ \ tycon_binders res_kind ->+ -- 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+ ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind ; tcg_env <- getGblEnv- ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind ; let hsc_src = tcg_src tcg_env ; unless (mk_permissive_kind hsc_src cons) $- checkDataKindSig (DataDeclSort new_or_data) final_res_kind+ checkDataKindSig (DataDeclSort new_or_data) final_res_kind ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta@@ -2274,7 +2519,7 @@ -- -- 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`. Therfore, this check need only occur in the code 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@@ -2292,7 +2537,7 @@ DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons)-tcDataDefn _ _ _ _ _ (XHsDataDefn nec) = noExtCon nec+tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec -------------------------@@ -2300,11 +2545,11 @@ -- Used for the equations of a closed type family only -- Not used for data/type instances kcTyFamInstEqn tc_fam_tc- (dL->L loc (HsIB { hsib_ext = imp_vars- , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name- , feqn_bndrs = mb_expl_bndrs- , feqn_pats = hs_pats- , feqn_rhs = hs_rhs_ty }}))+ (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@@ -2325,14 +2570,13 @@ -- type family Bar x y where -- Bar (x :: a) (y :: b) = Int -- Bar (x :: c) (y :: d) = Bool- -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately+ -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately } where vis_arity = length (tyConVisibleTyVars tc_fam_tc) -kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs nec)) = noExtCon nec-kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn nec))) = noExtCon nec-kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884+kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec+kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec --------------------------@@ -2342,14 +2586,20 @@ -- (typechecked here) have TyFamInstEqns tcTyFamInstEqn fam_tc mb_clsinfo- (dL->L loc (HsIB { hsib_ext = imp_vars+ (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 }})) = ASSERT( getName fam_tc == eqn_tc_name ) setSrcSpan loc $- do {+ 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.@@ -2416,10 +2666,10 @@ so visible type application etc plays no role. So, the simple thing is- - gather candiates from [k, a, b] and pats+ - gather candidates from [k, a, b] and pats - quantify over them -Hence the sligtly mysterious call:+Hence the slightly mysterious call: candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs) Simple, neat, but a little non-obvious!@@ -2433,7 +2683,7 @@ -> 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 {" (vcat [ ppr fam_tc <+> ppr hs_pats ])+ = 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@@ -2462,6 +2712,13 @@ ; 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@@ -2487,7 +2744,7 @@ ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ setXOptM LangExt.PartialTypeSignatures $ -- See Note [Wildcards in family instances] in- -- RnSource.hs+ -- GHC.Rename.Source tcInferApps typeLevelMode lhs_fun fun_ty hs_pats ; traceTc "End tcFamTyPats }" $@@ -2642,8 +2899,8 @@ ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool-consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True-consUseGadtSyntax _ = False+consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True+consUseGadtSyntax _ = False -- All constructors have same shape -----------------------------------@@ -2734,7 +2991,7 @@ -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in DataCon. user_tvbs = univ_tvbs ++ ex_tvbs- buildOneDataCon (dL->L _ name) = do+ buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name @@ -2762,7 +3019,7 @@ , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names)- ; let ((dL->L _ name) : _) = names+ ; let (L _ name : _) = names ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise@@ -2784,7 +3041,7 @@ ; return (ctxt, final_arg_tys, res_ty, field_lbls, stricts) } ; imp_tvs <- zonkAndScopedSort imp_tvs- ; let user_tvs = imp_tvs ++ exp_tvs+ ; let user_tvs = imp_tvs ++ exp_tvs ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ mkPhiTy ctxt $@@ -2821,7 +3078,7 @@ -- 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 (dL->L _ name) = do+ buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name @@ -2875,7 +3132,7 @@ = mapM tcConArg btys where -- We need a one-to-one mapping from field_names to btys- combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))+ combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined@@ -3342,7 +3599,7 @@ This is really bogus; now we have in scope a Class that is invalid in some way, with unknown downstream consequences. A better- alterantive might be to make a fake class TyCon. A job for another day.+ alternative might be to make a fake class TyCon. A job for another day. -} -------------------------@@ -3365,6 +3622,13 @@ | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim = return () + | isWiredInName (getName 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@@ -3438,7 +3702,7 @@ -- NB: this check assumes that all the constructors of a given -- data type use the same type variables where- (_, _, _, res1) = dataConSig con1+ res1 = dataConOrigResTy con1 fty1 = dataConFieldType con1 lbl lbl = flLabel label @@ -3446,7 +3710,7 @@ = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } where- (_, _, _, res2) = dataConSig con2+ res2 = dataConOrigResTy con2 fty2 = dataConFieldType con2 lbl checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()@@ -3546,12 +3810,12 @@ user_tvbs_invariant = Set.fromList (filterEqSpec eq_spec univs ++ exs) == Set.fromList user_tvs- ; WARN( not user_tvbs_invariant+ ; MASSERT2( user_tvbs_invariant , vcat ([ ppr con , ppr univs , ppr exs , ppr eq_spec- , ppr user_tvs ])) return () }+ , ppr user_tvs ])) } ; traceTc "Done validity of data con" $ vcat [ ppr con@@ -3932,7 +4196,7 @@ 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 accomodate this. As a result,+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@@ -4040,7 +4304,7 @@ check_roles = whenIsJust role_annot_decl_maybe $- \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->+ \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> addRoleAnnotCtxt name $ setSrcSpan loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations@@ -4064,11 +4328,10 @@ = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()-checkRoleAnnot _ (dL->L _ Nothing) _ = return ()-checkRoleAnnot tv (dL->L _ (Just r1)) r2+checkRoleAnnot _ (L _ Nothing) _ = return ()+checkRoleAnnot tv (L _ (Just r1)) r2 = when (r1 /= r2) $ addErrTc $ badRoleAnnot (tyVarName tv) r1 r2-checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884 -- This is a double-check on the role inference algorithm. It is only run when -- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls@@ -4158,6 +4421,38 @@ ************************************************************************ -} +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."+ ]+ tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)@@ -4355,25 +4650,21 @@ , text "is required" ]) wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc-wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))+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)-wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec-wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"- -- due to #15884+wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()-illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))+illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpan loc $ addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ text "they are allowed only for datatypes and classes.")-illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl nec)) = noExtCon nec-illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"- -- due to #15884+illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec needXRoleAnnotations :: TyCon -> SDoc needXRoleAnnotations tc
compiler/typecheck/TcUnify.hs view
@@ -1192,18 +1192,14 @@ ; return (emptyTcEvBinds, res) } } checkTvConstraints :: SkolemInfo- -> Maybe SDoc -- User-written telescope, if present- -> TcM ([TcTyVar], result)- -> TcM ([TcTyVar], result)--checkTvConstraints skol_info m_telescope thing_inside- = do { (tclvl, wanted, (skol_tvs, result))- <- pushLevelAndCaptureConstraints thing_inside-- ; emitResidualTvConstraint skol_info m_telescope- skol_tvs tclvl wanted+ -> [TcTyVar] -- Skolem tyvars+ -> TcM result+ -> TcM result - ; return (skol_tvs, result) }+checkTvConstraints skol_info skol_tvs thing_inside+ = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+ ; emitResidualTvConstraint skol_info Nothing skol_tvs tclvl wanted+ ; return result } emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM ()
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 8.10.1.20200916+version: 8.10.2.20200808 license: BSD3 license-file: LICENSE category: Development@@ -52,6 +52,7 @@ library default-language: Haskell2010+ default-extensions: NoImplicitPrelude exposed: False include-dirs: includes@@ -80,7 +81,7 @@ transformers == 0.5.*, process >= 1 && < 1.7, hpc == 0.6.*,- ghc-lib-parser == 8.10.1.20200916+ ghc-lib-parser == 8.10.2.20200808 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -115,8 +116,6 @@ TypeSynonymInstances UnboxedTuples UndecidableInstances- default-extensions:- NoImplicitPrelude hs-source-dirs: ghc-lib/stage0/libraries/ghc-boot/build ghc-lib/stage0/compiler/build
ghc-lib/stage0/lib/DerivedConstants.h view
@@ -491,22 +491,22 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 277+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 285 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 220+#define OFFSET_RtsFlags_DebugFlags_apply 228 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 215+#define OFFSET_RtsFlags_DebugFlags_sanity 223 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 210+#define OFFSET_RtsFlags_DebugFlags_weak 218 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16 #define REP_RtsFlags_GcFlags_initialStkSize b32 #define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 184+#define OFFSET_RtsFlags_MiscFlags_tickInterval 192 #define REP_RtsFlags_MiscFlags_tickInterval b64 #define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval] #define SIZEOF_StgFunInfoExtraFwd 32
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,7 +5,7 @@ # define __GLASGOW_HASKELL__ 810 #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 1+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 2 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -12,6 +12,8 @@ ,("ld supports build-id", "NO") ,("ld supports filelist", "YES") ,("ld is GNU ld", "NO")+,("Merge objects command", "ld")+,("Merge objects flags", "-r") ,("ar command", "ar") ,("ar flags", "qcls") ,("ar supports at file", "NO")