diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h --- a/compiler/CodeGen.Platform.h +++ b/compiler/CodeGen.Platform.h @@ -1,8 +1,7 @@ import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ - || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \ - || defined(MACHREGS_aarch64)) + || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg @@ -274,77 +273,6 @@ # define fr31 63 # endif -#elif defined(MACHREGS_sparc) - -# define g0 0 -# define g1 1 -# define g2 2 -# define g3 3 -# define g4 4 -# define g5 5 -# define g6 6 -# define g7 7 - -# define o0 8 -# define o1 9 -# define o2 10 -# define o3 11 -# define o4 12 -# define o5 13 -# define o6 14 -# define o7 15 - -# define l0 16 -# define l1 17 -# define l2 18 -# define l3 19 -# define l4 20 -# define l5 21 -# define l6 22 -# define l7 23 - -# define i0 24 -# define i1 25 -# define i2 26 -# define i3 27 -# define i4 28 -# define i5 29 -# define i6 30 -# define i7 31 - -# define f0 32 -# define f1 33 -# define f2 34 -# define f3 35 -# define f4 36 -# define f5 37 -# define f6 38 -# define f7 39 -# define f8 40 -# define f9 41 -# define f10 42 -# define f11 43 -# define f12 44 -# define f13 45 -# define f14 46 -# define f15 47 -# define f16 48 -# define f17 49 -# define f18 50 -# define f19 51 -# define f20 52 -# define f21 53 -# define f22 54 -# define f23 55 -# define f24 56 -# define f25 57 -# define f26 58 -# define f27 59 -# define f28 60 -# define f29 61 -# define f30 62 -# define f31 63 - #elif defined(MACHREGS_s390x) # define r0 0 @@ -734,7 +662,7 @@ -- reg is the machine register it is stored in. globalRegMaybe :: GlobalReg -> Maybe RealReg #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ - || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \ + || defined(MACHREGS_powerpc) \ || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \ || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) # if defined(REG_Base) @@ -789,52 +717,22 @@ globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) # endif # if defined(REG_D1) -globalRegMaybe (DoubleReg 1) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D1 (REG_D1 + 1)) -# else - Just (RealRegSingle REG_D1) -# endif +globalRegMaybe (DoubleReg 1) = Just (RealRegSingle REG_D1) # endif # if defined(REG_D2) -globalRegMaybe (DoubleReg 2) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D2 (REG_D2 + 1)) -# else - Just (RealRegSingle REG_D2) -# endif +globalRegMaybe (DoubleReg 2) = Just (RealRegSingle REG_D2) # endif # if defined(REG_D3) -globalRegMaybe (DoubleReg 3) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D3 (REG_D3 + 1)) -# else - Just (RealRegSingle REG_D3) -# endif +globalRegMaybe (DoubleReg 3) = Just (RealRegSingle REG_D3) # endif # if defined(REG_D4) -globalRegMaybe (DoubleReg 4) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D4 (REG_D4 + 1)) -# else - Just (RealRegSingle REG_D4) -# endif +globalRegMaybe (DoubleReg 4) = Just (RealRegSingle REG_D4) # endif # if defined(REG_D5) -globalRegMaybe (DoubleReg 5) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D5 (REG_D5 + 1)) -# else - Just (RealRegSingle REG_D5) -# endif +globalRegMaybe (DoubleReg 5) = Just (RealRegSingle REG_D5) # endif # if defined(REG_D6) -globalRegMaybe (DoubleReg 6) = -# if defined(MACHREGS_sparc) - Just (RealRegPair REG_D6 (REG_D6 + 1)) -# else - Just (RealRegSingle REG_D6) -# endif +globalRegMaybe (DoubleReg 6) = Just (RealRegSingle REG_D6) # endif # if MAX_REAL_XMM_REG != 0 # if defined(REG_XMM1) @@ -1107,149 +1005,6 @@ freeReg REG_D6 = False # endif -freeReg _ = True - -#elif defined(MACHREGS_sparc) - --- SPARC regs used by the OS / ABI --- %g0(r0) is always zero -freeReg g0 = False - --- %g5(r5) - %g7(r7) --- are reserved for the OS -freeReg g5 = False -freeReg g6 = False -freeReg g7 = False - --- %o6(r14) --- is the C stack pointer -freeReg o6 = False - --- %o7(r15) --- holds the C return address -freeReg o7 = False - --- %i6(r30) --- is the C frame pointer -freeReg i6 = False - --- %i7(r31) --- is used for C return addresses -freeReg i7 = False - --- %f0(r32) - %f1(r32) --- are C floating point return regs -freeReg f0 = False -freeReg f1 = False - -{- -freeReg regNo - -- don't release high half of double regs - | regNo >= f0 - , regNo < NCG_FirstFloatReg - , regNo `mod` 2 /= 0 - = False --} - -# if defined(REG_Base) -freeReg REG_Base = False -# endif -# if defined(REG_R1) -freeReg REG_R1 = False -# endif -# if defined(REG_R2) -freeReg REG_R2 = False -# endif -# if defined(REG_R3) -freeReg REG_R3 = False -# endif -# if defined(REG_R4) -freeReg REG_R4 = False -# endif -# if defined(REG_R5) -freeReg REG_R5 = False -# endif -# if defined(REG_R6) -freeReg REG_R6 = False -# endif -# if defined(REG_R7) -freeReg REG_R7 = False -# endif -# if defined(REG_R8) -freeReg REG_R8 = False -# endif -# if defined(REG_R9) -freeReg REG_R9 = False -# endif -# if defined(REG_R10) -freeReg REG_R10 = False -# endif -# if defined(REG_F1) -freeReg REG_F1 = False -# endif -# if defined(REG_F2) -freeReg REG_F2 = False -# endif -# if defined(REG_F3) -freeReg REG_F3 = False -# endif -# if defined(REG_F4) -freeReg REG_F4 = False -# endif -# if defined(REG_F5) -freeReg REG_F5 = False -# endif -# if defined(REG_F6) -freeReg REG_F6 = False -# endif -# if defined(REG_D1) -freeReg REG_D1 = False -# endif -# if defined(REG_D1_2) -freeReg REG_D1_2 = False -# endif -# if defined(REG_D2) -freeReg REG_D2 = False -# endif -# if defined(REG_D2_2) -freeReg REG_D2_2 = False -# endif -# if defined(REG_D3) -freeReg REG_D3 = False -# endif -# if defined(REG_D3_2) -freeReg REG_D3_2 = False -# endif -# if defined(REG_D4) -freeReg REG_D4 = False -# endif -# if defined(REG_D4_2) -freeReg REG_D4_2 = False -# endif -# if defined(REG_D5) -freeReg REG_D5 = False -# endif -# if defined(REG_D5_2) -freeReg REG_D5_2 = False -# endif -# if defined(REG_D6) -freeReg REG_D6 = False -# endif -# if defined(REG_D6_2) -freeReg REG_D6_2 = False -# endif -# if defined(REG_Sp) -freeReg REG_Sp = False -# endif -# if defined(REG_SpLim) -freeReg REG_SpLim = False -# endif -# if defined(REG_Hp) -freeReg REG_Hp = False -# endif -# if defined(REG_HpLim) -freeReg REG_HpLim = False -# endif freeReg _ = True #else diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -31,11 +31,9 @@ -- * Miscellaneous wiredInIds, ghcPrimIds, - primOpRules, builtinRules, ghcPrimExports, ghcPrimDeclDocs, - primOpId, -- * Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -49,6 +47,7 @@ import GHC.Builtin.Uniques import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Types import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Builtin.Types.Prim @@ -56,7 +55,6 @@ import GHC.Builtin.Names import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.Opt.ConstantFold import GHC.Core.DataCon import GHC.Core.Class import GHC.Core.TyCon @@ -81,7 +79,6 @@ import Control.Applicative ((<|>)) import Data.List ( intercalate , find ) -import Data.Array import Data.Maybe import qualified Data.Map as Map @@ -133,7 +130,7 @@ , concatMap wired_tycon_kk_names wiredInTyCons , concatMap wired_tycon_kk_names typeNatTyCons , map idName wiredInIds - , map (idName . primOpId) allThePrimOps + , map idName allThePrimOpIds , map (idName . primOpWrapperId) allThePrimOps , basicKnownKeyNames , templateHaskellNames @@ -230,22 +227,8 @@ We let a lot of "non-standard" values be visible, so that we can make sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. - -************************************************************************ -* * - PrimOpIds -* * -************************************************************************ -} -primOpIds :: Array Int Id --- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] - -primOpId :: PrimOp -> Id -primOpId op = primOpIds ! primOpTag op - {- ************************************************************************ * * @@ -257,7 +240,7 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports = map (avail . idName) ghcPrimIds ++ - map (avail . idName . primOpId) allThePrimOps ++ + map (avail . idName) allThePrimOpIds ++ [ availTC n [n] [] | tc <- exposedPrimTyCons, let n = tyConName tc ] @@ -265,7 +248,7 @@ ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs where names = map idName ghcPrimIds ++ - map (idName . primOpId) allThePrimOps ++ + map idName allThePrimOpIds ++ map tyConName exposedPrimTyCons findName (nameStr, doc) | Just name <- find ((nameStr ==) . getOccString) names diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -5,7 +5,6 @@ srtEscape, -- info table accessors - PtrOpts (..), closureInfoPtr, entryCode, getConstrTag, @@ -439,25 +438,19 @@ -- ------------------------------------------------------------------------- -data PtrOpts = PtrOpts - { po_profile :: !Profile -- ^ Platform profile - , po_align_check :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@) - } - -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled. -wordAligned :: PtrOpts -> CmmExpr -> CmmExpr -wordAligned opts e - | po_align_check opts +wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +wordAligned platform align_check e + | align_check = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e] | otherwise = e - where platform = profilePlatform (po_profile opts) -- | Takes a closure pointer and returns the info table pointer -closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr -closureInfoPtr opts e = - CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts))) +closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr +closureInfoPtr platform align_check e = + CmmLoad (wordAligned platform align_check e) (bWord platform) -- | Takes an info pointer (the first word of a closure) and returns its entry -- code @@ -471,23 +464,21 @@ -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). -getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr -getConstrTag opts closure_ptr +getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +getConstrTag profile align_check closure_ptr = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table] where - info_table = infoTable profile (closureInfoPtr opts closure_ptr) + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) platform = profilePlatform profile - profile = po_profile opts -- | Takes a closure pointer, and return the closure type -- obtained from the info table -cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr -cmmGetClosureType opts closure_ptr +cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr +cmmGetClosureType profile align_check closure_ptr = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table] where - info_table = infoTable profile (closureInfoPtr opts closure_ptr) + info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr) platform = profilePlatform profile - profile = po_profile opts -- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -208,6 +208,7 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.StgToCmm import GHC.Platform import GHC.Platform.Profile @@ -217,13 +218,14 @@ import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff - , getUpdFrameOff, getProfile, getPlatform, getPtrOpts ) + , getUpdFrameOff, getProfile, getPlatform, getContext) import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign import GHC.StgToCmm.Expr import GHC.StgToCmm.Lit import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout hiding (ArgRep(..)) import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof @@ -238,7 +240,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel -import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts) +import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout @@ -449,10 +451,10 @@ { do ((entry_ret_label, info, stk_formals, formals), agraph) <- getCodeScoped $ loopDecls $ do { (entry_ret_label, info, stk_formals) <- $1; - dflags <- getDynFlags; platform <- getPlatform; + ctx <- getContext; formals <- sequence (fromMaybe [] $3); - withName (showSDoc dflags (pdoc platform entry_ret_label)) + withName (renderWithContext ctx (pdoc platform entry_ret_label)) $4; return (entry_ret_label, info, stk_formals, formals) } let do_layout = isJust $3 @@ -925,8 +927,9 @@ exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do - ptr_opts <- PD.getPtrOpts - case lookupUFM (exprMacros ptr_opts) name of + profile <- PD.getProfile + align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags + case lookupUFM (exprMacros profile align_check) name of Just f -> return $ do args <- sequence args_code return (f args) @@ -934,21 +937,20 @@ mo <- nameToMachOp name return $ mkMachOp mo args_code -exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr) -exprMacros ptr_opts = listToUFM [ +exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr) +exprMacros profile align_check = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr ptr_opts x ), - ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr platform align_check x ), + ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr platform align_check x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) ] where - profile = po_profile ptr_opts platform = profilePlatform profile -- we understand a subset of C-- primitives: @@ -1513,13 +1515,14 @@ return (warnings, errors, Nothing) POk pst code -> do st <- initC + let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags) let fcode = do ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () let used_info = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm) ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info return (cmm ++ cmm2, used_info) - (cmm, _) = runC dflags no_module st fcode + (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing) diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs --- a/compiler/GHC/Cmm/Parser/Monad.hs +++ b/compiler/GHC/Cmm/Parser/Monad.hs @@ -13,7 +13,6 @@ , failMsgPD , getProfile , getPlatform - , getPtrOpts , getHomeUnitId ) where @@ -21,7 +20,6 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.Cmm.Info import Control.Monad @@ -68,15 +66,6 @@ getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile - -getPtrOpts :: PD PtrOpts -getPtrOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ PtrOpts - { po_profile = profile - , po_align_check = gopt Opt_AlignmentSanitisation dflags - } -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -82,7 +82,6 @@ import qualified GHC.CmmToAsm.X86 as X86 import qualified GHC.CmmToAsm.PPC as PPC -import qualified GHC.CmmToAsm.SPARC as SPARC import qualified GHC.CmmToAsm.AArch64 as AArch64 import GHC.CmmToAsm.Reg.Liveness @@ -161,8 +160,6 @@ ArchX86_64 -> nCG' (X86.ncgX86_64 config) ArchPPC -> nCG' (PPC.ncgPPC config) ArchPPC_64 _ -> nCG' (PPC.ncgPPC config) - ArchSPARC -> nCG' (SPARC.ncgSPARC config) - ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64" ArchS390X -> panic "nativeCodeGen: No NCG for S390X" ArchARM {} -> panic "nativeCodeGen: No NCG for ARM" ArchAArch64 -> nCG' (AArch64.ncgAArch64 config) @@ -672,29 +669,18 @@ invert (CmmProc info lbl live (ListGraph blocks)) = CmmProc info lbl live (ListGraph $ invertConds info blocks) - ---- expansion of SPARC synthetic instrs - let expanded = - {-# SCC "sparc_expand" #-} - ncgExpandTop ncgImpl branchOpt - --ncgExpandTop ncgImpl sequenced - - putDumpFileMaybe logger - Opt_D_dump_asm_expanded "Synthetic instructions expanded" - FormatCMM - (vcat $ map (pprNatCmmDecl ncgImpl) expanded) - -- generate unwinding information from cmm let unwinds :: BlockMap [UnwindPoint] unwinds = {-# SCC "unwindingInfo" #-} - foldl' addUnwind mapEmpty expanded + foldl' addUnwind mapEmpty branchOpt where addUnwind acc proc = acc `mapUnion` computeUnwinding config ncgImpl proc return ( usAlloc , fileIds' - , expanded + , branchOpt , lastMinuteImports ++ imports , ppr_raStatsColor , ppr_raStatsLinear diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -32,7 +32,6 @@ ,maxSpillSlots = AArch64.maxSpillSlots config ,allocatableRegs = AArch64.allocatableRegs platform ,ncgAllocMoreStack = AArch64.allocMoreStack platform - ,ncgExpandTop = id ,ncgMakeFarBranches = const id ,extractUnwindPoints = const [] ,invertCondBranches = \_ _ -> id diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -164,8 +164,6 @@ interesting _ (RegVirtual _) = True interesting _ (RegReal (RealRegSingle (-1))) = False interesting platform (RegReal (RealRegSingle i)) = freeReg platform i - interesting _ (RegReal (RealRegPair{})) - = panic "AArch64.Instr.interesting: no reg pairs on this arch" -- Save caller save registers -- This is x0-x18 diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs @@ -339,7 +339,6 @@ pprReg :: Width -> Reg -> SDoc pprReg w r = case r of RegReal (RealRegSingle i) -> ppr_reg_no w i - RegReal (RealRegPair{}) -> panic "AArch64.pprReg: no reg pairs on this arch!" -- virtual regs should not show up, but this is helpful for debugging. RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs --- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Regs.hs @@ -129,16 +129,12 @@ | regNo < 32 -> 1 -- first fp reg is 32 | otherwise -> 0 - RealRegPair{} -> 0 - RcDouble -> case rr of RealRegSingle regNo | regNo < 32 -> 0 | otherwise -> 1 - RealRegPair{} -> 0 - _other -> 0 mkVirtualReg :: Unique -> Format -> VirtualReg @@ -155,9 +151,6 @@ classOfRealReg (RealRegSingle i) | i < 32 = RcInteger | otherwise = RcDouble - -classOfRealReg (RealRegPair{}) - = panic "regClass(ppr): no reg pairs on this architecture" regDotColor :: RealReg -> SDoc regDotColor reg diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -82,7 +82,6 @@ pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr], ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]), -- ^ The list of block ids records the redirected jumps to allow us to update diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -32,7 +32,6 @@ , maxSpillSlots = PPC.maxSpillSlots config , allocatableRegs = PPC.allocatableRegs platform , ncgAllocMoreStack = PPC.allocMoreStack platform - , ncgExpandTop = id , ncgMakeFarBranches = PPC.makeFarBranches , extractUnwindPoints = const [] , invertCondBranches = \_ _ -> id diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -391,9 +391,6 @@ interesting :: Platform -> Reg -> Bool interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) - = panic "PPC.Instr.interesting: no reg pairs on this arch" - -- | Apply a given mapping to all the register references in this diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -199,7 +199,6 @@ pprReg r = case r of RegReal (RealRegSingle i) -> ppr_reg_no i - RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -100,7 +100,6 @@ | regNo < 32 -> 1 -- first fp reg is 32 | otherwise -> 0 - RealRegPair{} -> 0 RcDouble -> case rr of @@ -108,7 +107,6 @@ | regNo < 32 -> 0 | otherwise -> 1 - RealRegPair{} -> 0 _other -> 0 @@ -238,9 +236,6 @@ classOfRealReg (RealRegSingle i) | i < 32 = RcInteger | otherwise = RcDouble - -classOfRealReg (RealRegPair{}) - = panic "regClass(ppr): no reg pairs on this architecture" showReg :: RegNo -> String showReg n diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -50,11 +50,6 @@ -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing --- ToDo: this code is currently shared between SPARC and LLVM. --- Similar functions for (single precision) floats are --- present in the SPARC backend only. We need to fix both --- LLVM and SPARC. - castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) castDoubleToWord8Array = U.castSTUArray diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -516,9 +516,6 @@ | RegReal (RealRegSingle i) <- r = mkRegSingleUnique i - | RegReal (RealRegPair r1 r2) <- r - = mkRegPairUnique (r1 * 65535 + r2) - | otherwise = error $ "RegSpillClean.getUnique: found virtual reg during spill clean," ++ "only real regs expected." diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -107,8 +107,6 @@ ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 - ArchSPARC -> 14 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 15 ArchARM _ _ _ -> panic "trivColorable ArchARM" -- We should be able to allocate *a lot* more in princple. @@ -142,8 +140,6 @@ ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 - ArchSPARC -> 22 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 0 ArchARM _ _ _ -> panic "trivColorable ArchARM" -- we can in princple address all the float regs as @@ -179,8 +175,6 @@ -- "dont need to solve conflicts" count that -- was chosen at some point in the past. ArchPPC -> 26 - ArchSPARC -> 11 - ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 20 ArchARM _ _ _ -> panic "trivColorable ArchARM" ArchAArch64 -> 32 diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -111,7 +111,6 @@ import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.JoinToTargets import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 @@ -217,8 +216,6 @@ ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) ArchS390X -> panic "linearRegAlloc ArchS390X" - ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) - ArchSPARC64 -> panic "linearRegAlloc ArchSPARC64" ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" ArchAArch64 -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs) diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs @@ -71,7 +71,6 @@ | r < 32 && testBit g r = FreeRegs (clearBit g r) f | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) -allocateReg _ _ = panic "Linear.AArch64.allocReg: bad reg" -- we start from 28 downwards... the logic is similar to the ppc logic. -- 31 is Stack Pointer @@ -134,4 +133,3 @@ | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r) | r > 31 = FreeRegs g (setBit f (r - 32)) | otherwise = FreeRegs (setBit g r) f -releaseReg _ _ = pprPanic "Linear.AArch64.releaseReg" (text "bad reg") diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -26,13 +26,11 @@ -- allocateReg f r = filter (/= r) f import qualified GHC.CmmToAsm.Reg.Linear.PPC as PPC -import qualified GHC.CmmToAsm.Reg.Linear.SPARC as SPARC import qualified GHC.CmmToAsm.Reg.Linear.X86 as X86 import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr -import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr import qualified GHC.CmmToAsm.X86.Instr as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr @@ -66,20 +64,12 @@ frInitFreeRegs = AArch64.initFreeRegs frReleaseReg = \_ -> AArch64.releaseReg -instance FR SPARC.FreeRegs where - frAllocateReg = SPARC.allocateReg - frGetFreeRegs = \_ -> SPARC.getFreeRegs - frInitFreeRegs = SPARC.initFreeRegs - frReleaseReg = SPARC.releaseReg - maxSpillSlots :: NCGConfig -> Int maxSpillSlots config = case platformArch (ncgPlatform config) of ArchX86 -> X86.Instr.maxSpillSlots config ArchX86_64 -> X86.Instr.maxSpillSlots config ArchPPC -> PPC.Instr.maxSpillSlots config ArchS390X -> panic "maxSpillSlots ArchS390X" - ArchSPARC -> SPARC.Instr.maxSpillSlots config - ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" ArchAArch64 -> AArch64.Instr.maxSpillSlots config ArchPPC_64 _ -> PPC.Instr.maxSpillSlots config diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -8,7 +8,6 @@ import GHC.Platform.Reg import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Platform import Data.Word @@ -38,9 +37,6 @@ | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f -releaseReg _ _ - = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" - initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) @@ -59,5 +55,3 @@ | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f -allocateReg _ _ - = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Free regs map for SPARC -module GHC.CmmToAsm.Reg.Linear.SPARC where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Regs -import GHC.Platform.Reg.Class -import GHC.Platform.Reg - -import GHC.Platform.Regs -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - -import Data.Word - - --------------------------------------------------------------------------------- --- SPARC is like PPC, except for twinning of floating point regs. --- When we allocate a double reg we must take an even numbered --- float reg, as well as the one after it. - - --- Holds bitmaps showing what registers are currently allocated. --- The float and double reg bitmaps overlap, but we only alloc --- float regs into the float map, and double regs into the double map. --- --- Free regs have a bit set in the corresponding bitmap. --- -data FreeRegs - = FreeRegs - !Word32 -- int reg bitmap regs 0..31 - !Word32 -- float reg bitmap regs 32..63 - !Word32 -- double reg bitmap regs 32..63 - -instance Show FreeRegs where - show = showFreeRegs - -instance Outputable FreeRegs where - ppr = text . showFreeRegs - --- | A reg map where no regs are free to be allocated. -noFreeRegs :: FreeRegs -noFreeRegs = FreeRegs 0 0 0 - - --- | The initial set of free regs. -initFreeRegs :: Platform -> FreeRegs -initFreeRegs platform - = foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs - - --- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily -getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 - | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 - | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) -#endif - where - go _ _ 0 _ - = [] - - go step bitmap mask ix - | bitmap .&. mask /= 0 - = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - - | otherwise - = go step bitmap (mask `shiftL` step) $! ix + step - - --- | Grab a register. -allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -allocateReg platform - reg@(RealRegSingle r) - (FreeRegs g f d) - - -- can't allocate free regs - | not $ freeReg platform r - = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) - - -- a general purpose reg - | r <= 31 - = let mask = complement (bitMask r) - in FreeRegs - (g .&. mask) - f - d - - -- a float reg - | r >= 32, r <= 63 - = let mask = complement (bitMask (r - 32)) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then complement (bitMask (r - 32)) - else complement (bitMask (r - 32 - 1)) - in FreeRegs - g - (f .&. mask) - (d .&. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - -allocateReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = complement (bitMask (r1 - 32)) - mask2 = complement (bitMask (r2 - 32)) - in - FreeRegs - g - ((f .&. mask1) .&. mask2) - (d .&. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) - - - --- | Release a register from allocation. --- The register liveness information says that most regs die after a C call, --- but we still don't want to allocate to some of them. --- -releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs -releaseReg platform - reg@(RealRegSingle r) - regs@(FreeRegs g f d) - - -- don't release pinned reg - | not $ freeReg platform r - = regs - - -- a general purpose reg - | r <= 31 - = let mask = bitMask r - in FreeRegs (g .|. mask) f d - - -- a float reg - | r >= 32, r <= 63 - = let mask = bitMask (r - 32) - - -- the mask of the double this FP reg aliases - maskLow = if r `mod` 2 == 0 - then bitMask (r - 32) - else bitMask (r - 32 - 1) - in FreeRegs - g - (f .|. mask) - (d .|. maskLow) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - -releaseReg _ - reg@(RealRegPair r1 r2) - (FreeRegs g f d) - - | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 - , r2 >= 32, r2 <= 63 - = let mask1 = bitMask (r1 - 32) - mask2 = bitMask (r2 - 32) - in - FreeRegs - g - ((f .|. mask1) .|. mask2) - (d .|. mask1) - - | otherwise - = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) - - - -bitMask :: Int -> Word32 -bitMask n = 1 `shiftL` n - - -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f) = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg" - initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) @@ -47,7 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f) = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs --- a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -8,7 +8,6 @@ import GHC.CmmToAsm.X86.Regs import GHC.Platform.Reg.Class import GHC.Platform.Reg -import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Outputable @@ -24,9 +23,6 @@ releaseReg (RealRegSingle n) (FreeRegs f) = FreeRegs (f .|. (1 `shiftL` n)) -releaseReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg" - initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) @@ -47,8 +43,4 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs f) = FreeRegs (f .&. complement (1 `shiftL` r)) - -allocateReg _ _ - = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg" - diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs --- a/compiler/GHC/CmmToAsm/Reg/Target.hs +++ b/compiler/GHC/CmmToAsm/Reg/Target.hs @@ -33,7 +33,6 @@ import qualified GHC.CmmToAsm.X86.Regs as X86 import qualified GHC.CmmToAsm.X86.RegInfo as X86 import qualified GHC.CmmToAsm.PPC.Regs as PPC -import qualified GHC.CmmToAsm.SPARC.Regs as SPARC import qualified GHC.CmmToAsm.AArch64.Regs as AArch64 @@ -44,8 +43,6 @@ ArchX86_64 -> X86.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze ArchS390X -> panic "targetVirtualRegSqueeze ArchS390X" - ArchSPARC -> SPARC.virtualRegSqueeze - ArchSPARC64 -> panic "targetVirtualRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.virtualRegSqueeze ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM" ArchAArch64 -> AArch64.virtualRegSqueeze @@ -64,8 +61,6 @@ ArchX86_64 -> X86.realRegSqueeze ArchPPC -> PPC.realRegSqueeze ArchS390X -> panic "targetRealRegSqueeze ArchS390X" - ArchSPARC -> SPARC.realRegSqueeze - ArchSPARC64 -> panic "targetRealRegSqueeze ArchSPARC64" ArchPPC_64 _ -> PPC.realRegSqueeze ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM" ArchAArch64 -> AArch64.realRegSqueeze @@ -83,8 +78,6 @@ ArchX86_64 -> X86.classOfRealReg platform ArchPPC -> PPC.classOfRealReg ArchS390X -> panic "targetClassOfRealReg ArchS390X" - ArchSPARC -> SPARC.classOfRealReg - ArchSPARC64 -> panic "targetClassOfRealReg ArchSPARC64" ArchPPC_64 _ -> PPC.classOfRealReg ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM" ArchAArch64 -> AArch64.classOfRealReg @@ -102,8 +95,6 @@ ArchX86_64 -> X86.mkVirtualReg ArchPPC -> PPC.mkVirtualReg ArchS390X -> panic "targetMkVirtualReg ArchS390X" - ArchSPARC -> SPARC.mkVirtualReg - ArchSPARC64 -> panic "targetMkVirtualReg ArchSPARC64" ArchPPC_64 _ -> PPC.mkVirtualReg ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM" ArchAArch64 -> AArch64.mkVirtualReg @@ -121,8 +112,6 @@ ArchX86_64 -> X86.regDotColor platform ArchPPC -> PPC.regDotColor ArchS390X -> panic "targetRegDotColor ArchS390X" - ArchSPARC -> SPARC.regDotColor - ArchSPARC64 -> panic "targetRegDotColor ArchSPARC64" ArchPPC_64 _ -> PPC.regDotColor ArchARM _ _ _ -> panic "targetRegDotColor ArchARM" ArchAArch64 -> AArch64.regDotColor diff --git a/compiler/GHC/CmmToAsm/SPARC.hs b/compiler/GHC/CmmToAsm/SPARC.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Native code generator for SPARC architectures -module GHC.CmmToAsm.SPARC - ( ncgSPARC - ) -where - -import GHC.Prelude -import GHC.Utils.Panic - -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Instr - -import qualified GHC.CmmToAsm.SPARC.Instr as SPARC -import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC -import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC -import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC -import qualified GHC.CmmToAsm.SPARC.Regs as SPARC -import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC - - -ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest -ncgSPARC config = NcgImpl - { ncgConfig = config - , cmmTopCodeGen = SPARC.cmmTopCodeGen - , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform - , getJumpDestBlockId = SPARC.getJumpDestBlockId - , canShortcut = SPARC.canShortcut - , shortcutStatics = SPARC.shortcutStatics - , shortcutJump = SPARC.shortcutJump - , pprNatCmmDecl = SPARC.pprNatCmmDecl config - , maxSpillSlots = SPARC.maxSpillSlots config - , allocatableRegs = SPARC.allocatableRegs - , ncgExpandTop = map SPARC.expandTop - , ncgMakeFarBranches = const id - , extractUnwindPoints = const [] - , invertCondBranches = \_ _ -> id - -- Allocating more stack space for spilling isn't currently supported for the - -- linear register allocator on SPARC, hence the panic below. - , ncgAllocMoreStack = noAllocMoreStack - } - where - platform = ncgPlatform config - - noAllocMoreStack amount _ - = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n" - ++ " If you are trying to compile SHA1.hs from the crypto library then this\n" - ++ " is a known limitation in the linear allocator.\n" - ++ "\n" - ++ " Try enabling the graph colouring allocator with -fregs-graph instead." - ++ " You can still file a bug report if you like.\n" - - --- | instance for sparc instruction set -instance Instruction SPARC.Instr where - regUsageOfInstr = SPARC.regUsageOfInstr - patchRegsOfInstr = SPARC.patchRegsOfInstr - isJumpishInstr = SPARC.isJumpishInstr - jumpDestsOfInstr = SPARC.jumpDestsOfInstr - patchJumpInstr = SPARC.patchJumpInstr - mkSpillInstr = SPARC.mkSpillInstr - mkLoadInstr = SPARC.mkLoadInstr - takeDeltaInstr = SPARC.takeDeltaInstr - isMetaInstr = SPARC.isMetaInstr - mkRegRegMoveInstr = SPARC.mkRegRegMoveInstr - takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr - mkJumpInstr = SPARC.mkJumpInstr - pprInstr = SPARC.pprInstr - mkComment = pure . SPARC.COMMENT - mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" - mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" diff --git a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs b/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/AddrMode.hs +++ /dev/null @@ -1,44 +0,0 @@ - -module GHC.CmmToAsm.SPARC.AddrMode ( - AddrMode(..), - addrOffset -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Base -import GHC.Platform.Reg - --- addressing modes ------------------------------------------------------------ - --- | Represents a memory address in an instruction. --- Being a RISC machine, the SPARC addressing modes are very regular. --- -data AddrMode - = AddrRegReg Reg Reg -- addr = r1 + r2 - | AddrRegImm Reg Imm -- addr = r1 + imm - - --- | Add an integer offset to the address in an AddrMode. --- -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - AddrRegImm r (ImmInt n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2)) - | otherwise -> Nothing - where n2 = n + off - - AddrRegImm r (ImmInteger n) - | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2))) - | otherwise -> Nothing - where n2 = n + toInteger off - - AddrRegReg r (RegReal (RealRegSingle 0)) - | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) - | otherwise -> Nothing - - _ -> Nothing diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ /dev/null @@ -1,70 +0,0 @@ - --- | Bits and pieces on the bottom of the module dependency tree. --- Also import the required constants, so we know what we're using. --- --- In the interests of cross-compilation, we want to free ourselves --- from the autoconf generated modules like "GHC.Settings.Constants" - -module GHC.CmmToAsm.SPARC.Base ( - wordLength, - wordLengthInBits, - spillSlotSize, - extraStackArgsHere, - fits13Bits, - is32BitInteger, - largeOffsetError -) - -where - -import GHC.Prelude - -import GHC.Utils.Panic - -import Data.Int - - --- On 32 bit SPARC, pointers are 32 bits. -wordLength :: Int -wordLength = 4 - -wordLengthInBits :: Int -wordLengthInBits - = wordLength * 8 - --- | We need 8 bytes because our largest registers are 64 bit. -spillSlotSize :: Int -spillSlotSize = 8 - - --- | We (allegedly) put the first six C-call arguments in registers; --- where do we start putting the rest of them? -extraStackArgsHere :: Int -extraStackArgsHere = 23 - - -{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-} --- | Check whether an offset is representable with 13 bits. -fits13Bits :: Integral a => a -> Bool -fits13Bits x = x >= -4096 && x < 4096 - --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i - = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - --- | Sadness. -largeOffsetError :: (Show a) => a -> b -largeOffsetError i - = panic ("ERROR: SPARC native-code generator cannot handle large offset (" - ++ show i ++ ");\nprobably because of large constant data structures;" ++ - "\nworkaround: use -fllvm on this module.\n") - - diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +++ /dev/null @@ -1,739 +0,0 @@ - - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2013 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GADTs #-} -module GHC.CmmToAsm.SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - --- NCG stuff: -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.SPARC.CodeGen.Sanity -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.CodeGen.CondCode -import GHC.CmmToAsm.SPARC.CodeGen.Gen64 -import GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig ) -import GHC.CmmToAsm.Config - --- Our intermediate code: -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Graph -import GHC.CmmToAsm.PIC -import GHC.Platform.Reg -import GHC.Cmm.CLabel -import GHC.CmmToAsm.CPrim - --- The rest: -import GHC.Types.Basic -import GHC.Data.FastString -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - -import Control.Monad ( mapAndUnzipM ) - --- | Top level code generation -cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl RawCmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) - = do let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - let tops = proc : concat statics - - return tops - -cmmTopCodeGen (CmmData sec dat) = - return [CmmData sec dat] -- no translation, we just use CmmStatic - - --- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. -basicBlockCodeGen :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl RawCmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - platform <- getPlatform - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - - -- do intra-block sanity checking - blocksChecked - = map (checkBlock platform block) - $ BasicBlock id top : other_blocks - - return (blocksChecked, statics) - - --- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - platform <- getPlatform - config <- getConfig - case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType platform src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> genSwitch config arg ids - CmmCall { cml_target = arg } -> genJump arg - - _ - -> panic "stmtToInstrs: statement should have been cps'd away" - - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Platform -> Maybe BlockId -> CmmStatic -jumpTableEntry platform Nothing = CmmStaticLit (CmmInt 0 (wordWidth platform)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- getAmode addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_IntCode _ reg src = do - platform <- getPlatform - r <- getRegister src - let dst = getRegisterReg platform reg - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - - - --- Floating point assignment to memory -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_FltCode pk addr src = do - platform <- getPlatform - Amode dst__2 code1 <- getAmode addr - (src__2, code2) <- getSomeReg src - tmp1 <- getNewRegNat pk - let - pk__2 = cmmExprType platform src - code__2 = code1 `appOL` code2 `appOL` - if formatToWidth pk == typeWidth pk__2 - then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] - return code__2 - --- Floating point assignment to a register/temporary -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_FltCode pk dstCmmReg srcCmmExpr = do - platform <- getPlatform - srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg platform dstCmmReg - - return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg - - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (toOL [CALL (Left target) 0 True, NOP]) - where - target = ImmCLbl lbl - -genJump tree - = do - (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - - - -genCondJump bid bool = do - CondCode is_float cond code <- getCondCode bool - return ( - code `appOL` - toOL ( - if is_float - then [NOP, BF cond False bid, NOP] - else [BI cond False bid, NOP] - ) - ) - - - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch config expr targets - | ncgPIC config - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg indexExpr - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] - where - indexExpr = cmmOffset platform exprWidened offset - -- We widen to a native-width register to santize the high bits - exprWidened = CmmMachOp - (MO_UU_Conv (cmmExprWidth platform expr) - (platformWordWidth platform)) - [expr] - (offset, ids) = switchTargetsToTable targets - platform = ncgPlatform config - -generateJumpTableForInstr :: Platform -> Instr - -> Maybe (NatCmmDecl RawCmmStatics Instr) -generateJumpTableForInstr platform (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry platform) ids - in Just (CmmData (Section ReadOnlyData label) (CmmStaticsRaw label jumpTable)) -generateJumpTableForInstr _ _ = Nothing - - - --- ----------------------------------------------------------------------------- --- Generating C calls - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (PrimTarget MO_ReadBarrier) _ _ - = return $ nilOL -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall target dest_regs args - = do -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - ForeignTarget expr _ - -> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - PrimTarget mop - -> do res <- outOfLineMachOp mop - case res of - Left lbl -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - platform <- getPlatform - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code platform dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg = do platform <- getPlatform - arg_to_int_vregs' platform arg - -arg_to_int_vregs' :: Platform -> CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs' platform arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType platform arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType platform arg - - case cmmTypeFormat pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- destination regs. --- -assign_code :: Platform -> [LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [dest] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg platform (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - config <- getConfig - mopExpr <- cmmMakeDynamicReference config CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> unsupported - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> unsupported - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_I64_ToI -> fsLit "hs_int64ToInt" - MO_I64_FromI -> fsLit "hs_intToInt64" - MO_W64_ToW -> fsLit "hs_word64ToWord" - MO_W64_FromW -> fsLit "hs_wordToWord64" - MO_x64_Neg -> fsLit "hs_neg64" - MO_x64_Add -> fsLit "hs_add64" - MO_x64_Sub -> fsLit "hs_sub64" - MO_x64_Mul -> fsLit "hs_mul64" - MO_I64_Quot -> fsLit "hs_quotInt64" - MO_I64_Rem -> fsLit "hs_remInt64" - MO_W64_Quot -> fsLit "hs_quotWord64" - MO_W64_Rem -> fsLit "hs_remWord64" - MO_x64_And -> fsLit "hs_and64" - MO_x64_Or -> fsLit "hs_or64" - MO_x64_Xor -> fsLit "hs_xor64" - MO_x64_Not -> fsLit "hs_not64" - MO_x64_Shl -> fsLit "hs_uncheckedShiftL64" - MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64" - MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64" - MO_x64_Eq -> fsLit "hs_eq64" - MO_x64_Ne -> fsLit "hs_ne64" - MO_I64_Ge -> fsLit "hs_geInt64" - MO_I64_Gt -> fsLit "hs_gtInt64" - MO_I64_Le -> fsLit "hs_leInt64" - MO_I64_Lt -> fsLit "hs_ltInt64" - MO_W64_Ge -> fsLit "hs_geWord64" - MO_W64_Gt -> fsLit "hs_gtWord64" - MO_W64_Le -> fsLit "hs_leWord64" - MO_W64_Lt -> fsLit "hs_ltWord64" - - MO_UF_Conv w -> word2FloatLabel w - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - MO_Memcmp _ -> fsLit "memcmp" - - MO_SuspendThread -> fsLit "suspendThread" - MO_ResumeThread -> fsLit "resumeThread" - - MO_BSwap w -> bSwapLabel w - MO_BRev w -> bRevLabel w - MO_PopCnt w -> popCntLabel w - MO_Pdep w -> pdepLabel w - MO_Pext w -> pextLabel w - MO_Clz w -> clzLabel w - MO_Ctz w -> ctzLabel w - MO_AtomicRMW w amop -> atomicRMWLabel w amop - MO_Cmpxchg w -> cmpxchgLabel w - MO_Xchg w -> xchgLabel w - MO_AtomicRead w -> atomicReadLabel w - MO_AtomicWrite w -> atomicWriteLabel w - - MO_S_Mul2 {} -> unsupported - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _) -> unsupported - where unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.Amode ( - getAmode -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format - -import GHC.Cmm - -import GHC.Data.OrdList - - --- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode - -getAmode tree@(CmmRegOff _ _) - = do platform <- getPlatform - getAmode (mangleIndexTree platform tree) - -getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) - | fits13Bits (-i) - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (-(fromInteger i)) - return (Amode (AddrRegImm reg off) code) - - -getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) - | fits13Bits i - = do - (reg, code) <- getSomeReg x - let - off = ImmInt (fromInteger i) - return (Amode (AddrRegImm reg off) code) - -getAmode (CmmMachOp (MO_Add _) [x, y]) - = do - (regX, codeX) <- getSomeReg x - (regY, codeY) <- getSomeReg y - let - code = codeX `appOL` codeY - return (Amode (AddrRegReg regX regY) code) - -getAmode (CmmLit lit) - = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) - -getAmode other - = do - (reg, code) <- getSomeReg other - let - off = ImmInt 0 - return (Amode (AddrRegImm reg off) code) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs +++ /dev/null @@ -1,119 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setFormatOfRegister, - - getRegisterReg, - mangleIndexTree -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Platform.Regs -import GHC.Cmm -import GHC.Cmm.Ppr.Expr () -- For Outputable instances -import GHC.Platform - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.OrdList - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - - --- | Condition codes passed up the tree. --- -data CondCode - = CondCode Bool Cond InstrBlock - - --- | a.k.a \"Register64\" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. --- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified --- -data ChildCode64 - = ChildCode64 - InstrBlock - Reg - - --- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode - - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock - - - --------------------------------------------------------------------------------- --- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - - --- | Change the format field in a Register. -setFormatOfRegister - :: Register -> Format -> Register - -setFormatOfRegister reg format - = case reg of - Fixed _ reg code -> Fixed format reg code - Any _ codefn -> Any format codefn - - --------------------------------------------------------------------------------- --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic - "SPARC.CodeGen.Base.getRegisterReg: global is in memory" - (ppr $ CmmGlobal mid) - - --- Expand CmmRegOff. ToDo: should we do it this way around, or convert --- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmExpr -> CmmExpr - -mangleIndexTree platform (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) - -mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +++ /dev/null @@ -1,115 +0,0 @@ -module GHC.CmmToAsm.SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format - -import GHC.Cmm - -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic - - -getCondCode :: CmmExpr -> NatM CondCode -getCondCode (CmmMachOp mop [x, y]) - = - case mop of - MO_F_Eq W32 -> condFltCode EQQ x y - MO_F_Ne W32 -> condFltCode NE x y - MO_F_Gt W32 -> condFltCode GTT x y - MO_F_Ge W32 -> condFltCode GE x y - MO_F_Lt W32 -> condFltCode LTT x y - MO_F_Le W32 -> condFltCode LE x y - - MO_F_Eq W64 -> condFltCode EQQ x y - MO_F_Ne W64 -> condFltCode NE x y - MO_F_Gt W64 -> condFltCode GTT x y - MO_F_Ge W64 -> condFltCode GE x y - MO_F_Lt W64 -> condFltCode LTT x y - MO_F_Le W64 -> condFltCode LE x y - - MO_Eq _ -> condIntCode EQQ x y - MO_Ne _ -> condIntCode NE x y - - MO_S_Gt _ -> condIntCode GTT x y - MO_S_Ge _ -> condIntCode GE x y - MO_S_Lt _ -> condIntCode LTT x y - MO_S_Le _ -> condIntCode LE x y - - MO_U_Gt _ -> condIntCode GU x y - MO_U_Ge _ -> condIntCode GEU x y - MO_U_Lt _ -> condIntCode LU x y - MO_U_Le _ -> condIntCode LEU x y - - _ -> do - platform <- getPlatform - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y])) - -getCondCode other = do - platform <- getPlatform - pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other) - - - - - --- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be --- passed back up the tree. - -condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condIntCode cond x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code' = code `snocOL` SUB False True src1 (RIImm src2) g0 - return (CondCode False cond code') - -condIntCode cond x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 - return (CondCode False cond code__2) - - -condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y = do - platform <- getPlatform - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType platform x - pk2 = cmmExprType platform y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeFormat pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp - return (CondCode True cond code__2) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Expand out synthetic instructions into single machine instrs. -module GHC.CmmToAsm.SPARC.CodeGen.Expand ( - expandTop -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Types -import GHC.Cmm - -import GHC.Platform.Reg - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.OrdList - --- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmDecl RawCmmStatics Instr -> NatCmmDecl RawCmmStatics Instr -expandTop top@(CmmData{}) - = top - -expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) - - --- | Expand out synthetic instructions in this block -expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr - -expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' - - --- | Expand out some instructions -expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - -expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs - - in is_misaligned `appOL` expandBlockInstrs is - - - --- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are referred to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. --- --- For example: --- ldd [%l1], (%f0 | %f1) --- --- gets mapped to --- ldd [$l1], %f0 --- -remapRegPair :: Instr -> Instr -remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg - - RegReal (RealRegPair r1 r2) - - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) - - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF - - - - --- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. --- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. --- -expandMisalignedDoubles :: Instr -> OrdList Instr -expandMisalignedDoubles instr - - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The high partner for this float reg. -fRegHi :: Reg -> Reg -fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - --- Can't take high partner for non-low reg. -fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +++ /dev/null @@ -1,690 +0,0 @@ --- | Evaluation of 32 bit values. -module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.CodeGen.CondCode -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.CodeGen.Gen64 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Cmm - -import Control.Monad (liftM) -import GHC.Data.OrdList -import GHC.Utils.Panic - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - - --- | Make code to evaluate a 32 bit expression. --- -getRegister :: CmmExpr -> NatM Register - -getRegister (CmmReg reg) - = do platform <- getPlatform - return (Fixed (cmmTypeFormat (cmmRegType platform reg)) - (getRegisterReg platform reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = do platform <- getPlatform - getRegister (mangleIndexTree platform tree) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - - --- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. -getRegister (CmmLit (CmmFloat f W32)) = do - - -- a label for the new data area - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - - let code dst = toOL [ - -- the data area - LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl - [CmmStaticLit (CmmFloat f W32)], - - -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - - return (Any FF32 code) - -getRegister (CmmLit (CmmFloat d W64)) = do - lbl <- getNewLabelNat - tmp <- getNewRegNat II32 - let code dst = toOL [ - LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - return (Any FF64 code) - - --- Unary machine ops -getRegister (CmmMachOp mop [x]) - = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - - - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intFormat rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intFormat rep) (XNOR False g0) x - - - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - - - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x - - - -- Unsigned integer word size conversions ---------- - - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intFormat to) x - - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intFormat W16) x - MO_UU_Conv W8 W32 -> conversionNop (intFormat W32) x - MO_UU_Conv W16 W32 -> conversionNop (intFormat W32) x - - - -- Signed integer word size conversions ------------ - - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x - - _ -> panic ("Unknown unary mach op: " ++ show mop) - - --- Binary machine ops -getRegister (CmmMachOp mop [x, y]) - = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y - - MO_S_MulMayOflo rep -> imulMayOflo rep x y - - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y - - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y - - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y - - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y - - MO_Mul rep -> trivialCode rep (SMUL False) x y - - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y - - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) - -getRegister (CmmLoad mem pk) = do - Amode src code <- getAmode mem - let - code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst - return (Any (cmmTypeFormat pk) code__2) - -getRegister (CmmLit (CmmInt i _)) - | fits13Bits i - = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) - in - return (Any II32 code) - -getRegister (CmmLit lit) - = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] - in return (Any II32 code) - - -getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" - - --- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register - -integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intFormat to) code) - - --- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. --- -conversionNop - :: Format -> CmmExpr -> NatM Register - -conversionNop new_rep expr - = do e_code <- getRegister expr - return (setFormatOfRegister e_code new_rep) - - - --- | Generate an integer division instruction. -idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - - --- | Do an integer remainder. --- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. --- --- The UltraSparc 2007 manual says Y is _undefined_ after division. --- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. --- -irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - - - --- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. --- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y - = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - - -imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b - = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` - toOL [ - SMUL False a_reg (RIReg b_reg) res_lo, - RDY res_hi, - SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, - SUB False False res_lo (RIReg res_hi) dst - ] - return (Any II32 code) - - --- ----------------------------------------------------------------------------- --- 'trivial*Code': deal with trivial instructions - --- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', --- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. --- Only look for constants on the right hand side, because that's --- where the generic optimizer will have put them. - --- Similarly, for unary instructions, we don't have to worry about --- matching an StInt as the argument, because genericOpt will already --- have handled the constant-folding. - -trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialCode _ instr x (CmmLit (CmmInt y _)) - | fits13Bits y - = do - (src1, code) <- getSomeReg x - let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst - return (Any II32 code__2) - - -trivialCode _ instr x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst - return (Any II32 code__2) - - -trivialFCode - :: Width - -> (Format -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - -trivialFCode pk instr x y = do - platform <- getPlatform - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - tmp <- getNewRegNat FF64 - let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType platform x - pk2 = cmmExprType platform y - - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatFormat pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) - - - -trivialUCode - :: Format - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUCode format instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr (RIReg src) dst - return (Any format code__2) - - -trivialUFCode - :: Format - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - -trivialUFCode pk instr x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `snocOL` instr src dst - return (Any pk code__2) - - - - --- Coercions ------------------------------------------------------------------- - --- | Coerce a integer value to floating point -coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register -coerceInt2FP width1 width2 x = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - ST (intFormat width1) src (spRel (-2)), - LD (intFormat width1) (spRel (-2)) dst, - FxTOy (intFormat width1) (floatFormat width2) dst dst] - return (Any (floatFormat $ width2) code__2) - - - --- | Coerce a floating point value to integer --- --- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. --- -coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fformat1 = floatFormat width1 - fformat2 = floatFormat width2 - - iformat2 = intFormat width2 - - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fformat2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fformat1 iformat2 fsrc fdst - - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fformat2 fdst (spRel (-2)) - , LD iformat2 (spRel (-2)) dst] - - return (Any iformat2 code2) - - --- | Coerce a double precision floating point value to single precision. -coerceDbl2Flt :: CmmExpr -> NatM Register -coerceDbl2Flt x = do - (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) - - --- | Coerce a single precision floating point value to double precision -coerceFlt2Dbl :: CmmExpr -> NatM Register -coerceFlt2Dbl x = do - (src, code) <- getSomeReg x - return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst)) - - - - --- Condition Codes ------------------------------------------------------------- --- --- Evaluate a comparison, and get the result into a register. --- --- Do not fill the delay slots here. you will confuse the register allocator. --- -condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg EQQ x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] - return (Any II32 code__2) - -condIntReg NE x (CmmLit (CmmInt 0 _)) = do - (src, code) <- getSomeReg x - let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg NE x y = do - (src1, code1) <- getSomeReg x - (src2, code2) <- getSomeReg y - let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] - return (Any II32 code__2) - -condIntReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - CondCode _ cond cond_code <- condIntCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2] - - return (Any II32 code__2) - - -condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register -condFltReg cond x y = do - bid1 <- liftM (\a -> seq a a) getBlockIdNat - bid2 <- liftM (\a -> seq a a) getBlockIdNat - - CondCode _ cond cond_code <- condFltCode cond x y - let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP - - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP - - , NEWBLOCK bid2 ] - - return (Any II32 code__2) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ - -module GHC.CmmToAsm.SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister -) - -where - -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.Monad -import GHC.Platform.Reg - -import GHC.Cmm - -getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) -getRegister :: CmmExpr -> NatM Register diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ /dev/null @@ -1,214 +0,0 @@ --- | Evaluation of 64 bit values on 32 bit platforms. -module GHC.CmmToAsm.SPARC.CodeGen.Gen64 ( - assignMem_I64Code, - assignReg_I64Code, - iselExpr64 -) - -where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.CmmToAsm.SPARC.CodeGen.Gen32 -import GHC.CmmToAsm.SPARC.CodeGen.Base -import GHC.CmmToAsm.SPARC.CodeGen.Amode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.Monad -import GHC.CmmToAsm.Format -import GHC.Platform.Reg - -import GHC.Cmm - -import GHC.Data.OrdList -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | Code to assign a 64 bit value to memory. -assignMem_I64Code - :: CmmExpr -- ^ expr producing the destination address - -> CmmExpr -- ^ expr producing the source value. - -> NatM InstrBlock - -assignMem_I64Code addrTree valueTree - = do - ChildCode64 vcode rlo <- iselExpr64 valueTree - - (src, acode) <- getSomeReg addrTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0)) - mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4)) - - code = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo - -{- pprTrace "assignMem_I64Code" - (vcat [ text "addrTree: " <+> ppr addrTree - , text "valueTree: " <+> ppr valueTree - , text "vcode:" - , vcat $ map ppr $ fromOL vcode - , text "" - , text "acode:" - , vcat $ map ppr $ fromOL acode ]) - $ -} - return code - - --- | Code to assign a 64 bit value to a register. -assignReg_I64Code - :: CmmReg -- ^ the destination register - -> CmmExpr -- ^ expr producing the source value - -> NatM InstrBlock - -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree - = do - ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let - r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk) - r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - - return (vcode `snocOL` mov_hi `snocOL` mov_lo) - -assignReg_I64Code _ _ - = panic "assignReg_I64Code(sparc): invalid lvalue" - - - - --- | Get the value of an expression into a 64 bit register. - -iselExpr64 :: CmmExpr -> NatM ChildCode64 - --- Load a 64 bit word -iselExpr64 (CmmLoad addrTree ty) - | isWord64 ty - = do Amode amode addr_code <- getAmode addrTree - let result - - | AddrRegReg r1 r2 <- amode - = do rlo <- getNewRegNat II32 - tmp <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ ADD False False r1 (RIReg r2) tmp - , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi - , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ]) - rlo - - | AddrRegImm r1 (ImmInt i) <- amode - = do rlo <- getNewRegNat II32 - let rhi = getHiVRegFromLo rlo - - return $ ChildCode64 - ( addr_code - `appOL` toOL - [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi - , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ]) - rlo - - | otherwise - = panic "SPARC.CodeGen.Gen64: no match" - - result - - --- Add a literal to a 64 bit integer -iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` toOL - [ ADD False True r1_lo (RIImm (ImmInteger i)) r_dst_lo - , ADD True False r1_hi (RIReg g0) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - --- Addition of II64 -iselExpr64 (CmmMachOp (MO_Add _) [e1, e2]) - = do ChildCode64 code1 r1_lo <- iselExpr64 e1 - let r1_hi = getHiVRegFromLo r1_lo - - ChildCode64 code2 r2_lo <- iselExpr64 e2 - let r2_hi = getHiVRegFromLo r2_lo - - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - let code = code1 - `appOL` code2 - `appOL` toOL - [ ADD False True r1_lo (RIReg r2_lo) r_dst_lo - , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) - | isWord64 ty - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = RegVirtual $ mkVirtualReg uq II32 - r_src_hi = getHiVRegFromLo r_src_lo - mov_lo = mkMOV r_src_lo r_dst_lo - mov_hi = mkMOV r_src_hi r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - return ( - ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo - ) - --- Convert something into II64 -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - platform <- getPlatform - let code = a_code - `appOL` toOL - [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - --- only W32 supported for now -iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) - = do - r_dst_lo <- getNewRegNat II32 - let r_dst_hi = getHiVRegFromLo r_dst_lo - - -- compute expr and load it into r_dst_lo - (a_reg, a_code) <- getSomeReg expr - - platform <- getPlatform - let code = a_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi - , mkRegRegMoveInstr platform a_reg r_dst_lo ] - - return $ ChildCode64 code r_dst_lo - - -iselExpr64 expr - = do - platform <- getPlatform - pprPanic "iselExpr64(sparc)" (pdoc platform expr) diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. -module GHC.CmmToAsm.SPARC.CodeGen.Sanity ( - checkBlock -) - -where - -import GHC.Prelude -import GHC.Platform - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances -import GHC.CmmToAsm.Types - -import GHC.Cmm - -import GHC.Utils.Outputable -import GHC.Utils.Panic - - --- | Enforce intra-block invariants. --- -checkBlock :: Platform - -> CmmBlock - -> NatBasicBlock Instr - -> NatBasicBlock Instr - -checkBlock platform cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , pdoc platform cmm - , text " -- native code ---------\n" - , pdoc platform block ]) - - -checkBlockInstrs :: [Instr] -> Bool -checkBlockInstrs ii - - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False diff --git a/compiler/GHC/CmmToAsm/SPARC/Cond.hs b/compiler/GHC/CmmToAsm/SPARC/Cond.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Cond.hs +++ /dev/null @@ -1,27 +0,0 @@ -module GHC.CmmToAsm.SPARC.Cond ( - Cond(..), -) - -where - -import GHC.Prelude - --- | Branch condition codes. -data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq diff --git a/compiler/GHC/CmmToAsm/SPARC/Imm.hs b/compiler/GHC/CmmToAsm/SPARC/Imm.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Imm.hs +++ /dev/null @@ -1,68 +0,0 @@ -module GHC.CmmToAsm.SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm -) - -where - -import GHC.Prelude - -import GHC.Cmm -import GHC.Cmm.CLabel - -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. --- -data Imm - = ImmInt Int - - -- Sigh. - | ImmInteger Integer - - -- AbstractC Label (with baggage) - | ImmCLbl CLabel - - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational - - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm - - | LO Imm - | HI Imm - - --- | Create a ImmLit containing this string. -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) - - --- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. --- -litToImm :: CmmLit -> Imm -litToImm lit - = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off - - CmmLabelDiffOff l1 l2 off _ - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) - - _ -> panic "SPARC.Regs.litToImm: no match" diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ /dev/null @@ -1,470 +0,0 @@ - - ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ -module GHC.CmmToAsm.SPARC.Instr - ( Instr(..) - , RI(..) - , riZero - , fpRelEA - , moveSp - , isUnconditionalJump - , maxSpillSlots - , patchRegsOfInstr - , patchJumpInstr - , mkRegRegMoveInstr - , mkLoadInstr - , mkSpillInstr - , mkJumpInstr - , takeDeltaInstr - , isMetaInstr - , isJumpishInstr - , jumpDestsOfInstr - , takeRegRegMoveInstr - , regUsageOfInstr - ) -where - -import GHC.Prelude -import GHC.Platform - -import GHC.CmmToAsm.SPARC.Stack -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.Reg.Target -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) - -import GHC.Platform.Reg.Class -import GHC.Platform.Reg -import GHC.Platform.Regs - -import GHC.Cmm.CLabel -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Utils.Outputable -import GHC.Utils.Panic - - --- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm - --- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. --- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False - - --- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. -fpRelEA :: Int -> Reg -> Instr -fpRelEA n dst - = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst - - --- | Code to shift the stack pointer by n words. -moveSp :: Int -> Instr -moveSp n - = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp - --- | An instruction that will cause the one after it never to be exectuted -isUnconditionalJump :: Instr -> Bool -isUnconditionalJump ii - = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False - - --- | SPARC instruction set. --- Not complete. This is only the ones we need. --- -data Instr - - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT SDoc - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section RawCmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Format AddrMode Reg -- format, src, dst - | ST Format Reg AddrMode -- format, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Format Reg Reg -- src dst - | FADD Format Reg Reg Reg -- src1, src2, dst - | FCMP Bool Format Reg Reg -- exception?, src1, src2, dst - | FDIV Format Reg Reg Reg -- src1, src2, dst - | FMOV Format Reg Reg -- src, dst - | FMUL Format Reg Reg Reg -- src1, src2, dst - | FNEG Format Reg Reg -- src, dst - | FSQRT Format Reg Reg -- src, dst - | FSUB Format Reg Reg Reg -- src1, src2, dst - | FxTOy Format Format Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal - - --- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. --- -regUsageOfInstr :: Platform -> Instr -> RegUsage -regUsageOfInstr platform instr - = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage - - where - usage (src, dst) - = RU (filter (interesting platform) src) - (filter (interesting platform) dst) - - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] - - regRI (RIReg r) = [r] - regRI _ = [] - - --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. -interesting :: Platform -> Reg -> Bool -interesting platform reg - = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> freeReg platform r1 - RegReal (RealRegPair r1 _) -> freeReg platform r1 - - - --- | Apply a given mapping to tall the register references in this instruction. -patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr -patchRegsOfInstr instr env = case instr of - LD fmt addr reg -> LD fmt (fixAddr addr) (env reg) - ST fmt reg addr -> ST fmt (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr - - where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - --------------------------------------------------------------------------------- -isJumpishInstr :: Instr -> Bool -isJumpishInstr instr - = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False - -jumpDestsOfInstr :: Instr -> [BlockId] -jumpDestsOfInstr insn - = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] - - -patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr -patchJumpInstr insn patchF - = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn - - --------------------------------------------------------------------------------- --- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill -mkSpillInstr - :: NCGConfig - -> Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> [Instr] - -mkSpillInstr config reg _ slot - = let platform = ncgPlatform config - off = spillSlotToOffset config slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in [ST fmt reg (fpRel (negate off_w))] - - --- | Make a spill reload instruction. -mkLoadInstr - :: NCGConfig - -> Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> [Instr] - -mkLoadInstr config reg _ slot - = let platform = ncgPlatform config - off = spillSlotToOffset config slot - off_w = 1 + (off `div` 4) - fmt = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - - in [LD fmt (fpRel (- off_w)) reg] - - --------------------------------------------------------------------------------- --- | See if this instruction is telling us the current C stack delta -takeDeltaInstr - :: Instr - -> Maybe Int - -takeDeltaInstr instr - = case instr of - DELTA i -> Just i - _ -> Nothing - - -isMetaInstr - :: Instr - -> Bool - -isMetaInstr instr - = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - - --- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- -mkRegRegMoveInstr - :: Platform - -> Reg - -> Reg - -> Instr - -mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" - - --- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. --- -takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) -takeRegRegMoveInstr instr - = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) - - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing - - --- | Make an unconditional branch instruction. -mkJumpInstr - :: BlockId - -> [Instr] - -mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - - ------------------------------------------------------------------------------ --- --- Pretty-printing assembly language --- --- (c) The University of Glasgow 1993-2005 --- ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module GHC.CmmToAsm.SPARC.Ppr ( - pprNatCmmDecl, - pprBasicBlock, - pprData, - pprInstr, - pprFormat, - pprImm, - pprDataItem -) - -where - -import GHC.Prelude - -import Data.Word -import qualified Data.Array.Unsafe as U ( castSTUArray ) -import Data.Array.ST - -import Control.Monad.ST - -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Cond -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Base -import GHC.Platform.Reg -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Ppr -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Types -import GHC.CmmToAsm.Utils - -import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Ppr() -- For Outputable instances -import GHC.Cmm.BlockId -import GHC.Cmm.CLabel -import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Collections - -import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Platform - --- ----------------------------------------------------------------------------- --- Printing this stuff out - -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc -pprNatCmmDecl config (CmmData section dats) = - pprSectionAlign config section - $$ pprDatas (ncgPlatform config) dats - -pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - let platform = ncgPlatform config in - case topInfoTable proc of - Nothing -> - -- special case for code without info table: - pprSectionAlign config (Section Text lbl) $$ - pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock platform top_info) blocks) - - Just (CmmStaticsRaw info_lbl _) -> - (if platformHasSubsectionsViaSymbols platform - then pprSectionAlign config dspSection $$ - pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' - else empty) $$ - vcat (map (pprBasicBlock platform top_info) blocks) $$ - -- above: Even the first block gets a label, because with branch-chain - -- elimination, it might be the target of a goto. - (if platformHasSubsectionsViaSymbols platform - then - -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> pdoc platform info_lbl - <+> char '-' - <+> pdoc platform (mkDeadStripPreventer info_lbl) - else empty) - -dspSection :: Section -dspSection = Section Text $ - panic "subsections-via-symbols doesn't combine with split-sections" - -pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock platform info_env (BasicBlock blockid instrs) - = maybe_infotable $$ - pprLabel platform (blockLbl blockid) $$ - vcat (map (pprInstr platform) instrs) - where - maybe_infotable = case mapLookup blockid info_env of - Nothing -> empty - Just (CmmStaticsRaw info_lbl info) -> - pprAlignForSection Text $$ - vcat (map (pprData platform) info) $$ - pprLabel platform info_lbl - - -pprDatas :: Platform -> RawCmmStatics -> SDoc --- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) - | lbl == mkIndStaticInfoLabel - , let labelInd (CmmLabelOff l _) = Just l - labelInd (CmmLabel l) = Just l - labelInd _ = Nothing - , Just ind' <- labelInd ind - , alias `mayRedirectTo` ind' - = pprGloblDecl platform alias - $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') -pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) - -pprData :: Platform -> CmmStatic -> SDoc -pprData platform d = case d of - CmmString str -> pprString str - CmmFileEmbed path -> pprFileEmbed path - CmmUninitialised bytes -> text ".skip " <> int bytes - CmmStaticLit lit -> pprDataItem platform lit - -pprGloblDecl :: Platform -> CLabel -> SDoc -pprGloblDecl platform lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".global " <> pdoc platform lbl - -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc -pprTypeAndSizeDecl platform lbl - = if platformOS platform == OSLinux && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> text ", @object" - else empty - -pprLabel :: Platform -> CLabel -> SDoc -pprLabel platform lbl = - pprGloblDecl platform lbl - $$ pprTypeAndSizeDecl platform lbl - $$ (pdoc platform lbl <> char ':') - --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - -instance OutputableP Platform Instr where - pdoc = pprInstr - - --- | Pretty print a register. -pprReg :: Reg -> SDoc -pprReg reg - = case reg of - RegVirtual vr - -> case vr of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - VirtualRegF u -> text "%vF_" <> pprUniqueAlways u - VirtualRegD u -> text "%vD_" <> pprUniqueAlways u - - - RegReal rr - -> case rr of - RealRegSingle r1 - -> pprReg_ofRegNo r1 - - RealRegPair r1 r2 - -> text "(" <> pprReg_ofRegNo r1 - <> vbar <> pprReg_ofRegNo r2 - <> text ")" - - - --- | Pretty print a register name, based on this register number. --- The definition has been unfolded so we get a jump-table in the --- object code. This function is called quite a lot when emitting --- the asm file.. --- -pprReg_ofRegNo :: Int -> SDoc -pprReg_ofRegNo i - = case i of { - 0 -> text "%g0"; 1 -> text "%g1"; - 2 -> text "%g2"; 3 -> text "%g3"; - 4 -> text "%g4"; 5 -> text "%g5"; - 6 -> text "%g6"; 7 -> text "%g7"; - 8 -> text "%o0"; 9 -> text "%o1"; - 10 -> text "%o2"; 11 -> text "%o3"; - 12 -> text "%o4"; 13 -> text "%o5"; - 14 -> text "%o6"; 15 -> text "%o7"; - 16 -> text "%l0"; 17 -> text "%l1"; - 18 -> text "%l2"; 19 -> text "%l3"; - 20 -> text "%l4"; 21 -> text "%l5"; - 22 -> text "%l6"; 23 -> text "%l7"; - 24 -> text "%i0"; 25 -> text "%i1"; - 26 -> text "%i2"; 27 -> text "%i3"; - 28 -> text "%i4"; 29 -> text "%i5"; - 30 -> text "%i6"; 31 -> text "%i7"; - 32 -> text "%f0"; 33 -> text "%f1"; - 34 -> text "%f2"; 35 -> text "%f3"; - 36 -> text "%f4"; 37 -> text "%f5"; - 38 -> text "%f6"; 39 -> text "%f7"; - 40 -> text "%f8"; 41 -> text "%f9"; - 42 -> text "%f10"; 43 -> text "%f11"; - 44 -> text "%f12"; 45 -> text "%f13"; - 46 -> text "%f14"; 47 -> text "%f15"; - 48 -> text "%f16"; 49 -> text "%f17"; - 50 -> text "%f18"; 51 -> text "%f19"; - 52 -> text "%f20"; 53 -> text "%f21"; - 54 -> text "%f22"; 55 -> text "%f23"; - 56 -> text "%f24"; 57 -> text "%f25"; - 58 -> text "%f26"; 59 -> text "%f27"; - 60 -> text "%f28"; 61 -> text "%f29"; - 62 -> text "%f30"; 63 -> text "%f31"; - _ -> text "very naughty sparc register" } - - --- | Pretty print a format for an instruction suffix. -pprFormat :: Format -> SDoc -pprFormat x - = case x of - II8 -> text "ub" - II16 -> text "uh" - II32 -> text "" - II64 -> text "d" - FF32 -> text "" - FF64 -> text "d" - - --- | Pretty print a format for an instruction suffix. --- eg LD is 32bit on sparc, but LDD is 64 bit. -pprStFormat :: Format -> SDoc -pprStFormat x - = case x of - II8 -> text "b" - II16 -> text "h" - II32 -> text "" - II64 -> text "x" - FF32 -> text "" - FF64 -> text "d" - - - --- | Pretty print a condition code. -pprCond :: Cond -> SDoc -pprCond c - = case c of - ALWAYS -> text "" - NEVER -> text "n" - GEU -> text "geu" - LU -> text "lu" - EQQ -> text "e" - GTT -> text "g" - GE -> text "ge" - GU -> text "gu" - LTT -> text "l" - LE -> text "le" - LEU -> text "leu" - NE -> text "ne" - NEG -> text "neg" - POS -> text "pos" - VC -> text "vc" - VS -> text "vs" - - --- | Pretty print an address mode. -pprAddr :: Platform -> AddrMode -> SDoc -pprAddr platform am - = case am of - AddrRegReg r1 (RegReal (RealRegSingle 0)) - -> pprReg r1 - - AddrRegReg r1 r2 - -> hcat [ pprReg r1, char '+', pprReg r2 ] - - AddrRegImm r1 (ImmInt i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, int i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 (ImmInteger i) - | i == 0 -> pprReg r1 - | not (fits13Bits i) -> largeOffsetError i - | otherwise -> hcat [ pprReg r1, pp_sign, integer i ] - where - pp_sign = if i > 0 then char '+' else empty - - AddrRegImm r1 imm - -> hcat [ pprReg r1, char '+', pprImm platform imm ] - - --- | Pretty print an immediate value. -pprImm :: Platform -> Imm -> SDoc -pprImm platform imm - = case imm of - ImmInt i -> int i - ImmInteger i -> integer i - ImmCLbl l -> pdoc platform l - ImmIndex l i -> pdoc platform l <> char '+' <> int i - ImmLit s -> s - - ImmConstantSum a b - -> pprImm platform a <> char '+' <> pprImm platform b - - ImmConstantDiff a b - -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen - - LO i - -> hcat [ text "%lo(", pprImm platform i, rparen ] - - HI i - -> hcat [ text "%hi(", pprImm platform i, rparen ] - - -- these should have been converted to bytes and placed - -- in the data section. - ImmFloat _ -> text "naughty float immediate" - ImmDouble _ -> text "naughty double immediate" - - --- | Pretty print a section \/ segment header. --- On SPARC all the data sections must be at least 8 byte aligned --- incase we store doubles in them. --- -pprSectionAlign :: NCGConfig -> Section -> SDoc -pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ - pprAlignForSection seg - --- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - case seg of - Text -> text ".align 4" - Data -> text ".align 8" - ReadOnlyData -> text ".align 8" - RelocatableReadOnlyData -> text ".align 8" - UninitialisedData -> text ".align 8" - ReadOnlyData16 -> text ".align 16" - -- TODO: This is copied from the ReadOnlyData case, but it can likely be - -- made more efficient. - CString -> text ".align 8" - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" - --- | Pretty print a data item. -pprDataItem :: Platform -> CmmLit -> SDoc -pprDataItem platform lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) - where - imm = litToImm lit - - ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] - ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] - - ppr_item FF32 (CmmFloat r _) - = let bs = floatToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - - ppr_item FF64 (CmmFloat r _) - = let bs = doubleToBytes (fromRational r) - in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - - ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm] - ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] - ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" - -floatToBytes :: Float -> [Int] -floatToBytes f - = runST (do - arr <- newArray_ ((0::Int),3) - writeArray arr 0 f - arr <- castFloatToWord8Array arr - i0 <- readArray arr 0 - i1 <- readArray arr 1 - i2 <- readArray arr 2 - i3 <- readArray arr 3 - return (map fromIntegral [i0,i1,i2,i3]) - ) - -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8) -castFloatToWord8Array = U.castSTUArray - - -asmComment :: SDoc -> SDoc -asmComment c = whenPprDebug $ text "#" <+> c - - --- | Pretty print an instruction. -pprInstr :: Platform -> Instr -> SDoc -pprInstr platform = \case - COMMENT s -> asmComment s - DELTA d -> asmComment $ text ("\tdelta = " ++ show d) - - -- Newblocks and LData should have been slurped out before producing the .s file. - NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK" - LDATA _ _ -> panic "PprMach.pprInstr: LDATA" - - -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand - LD FF64 _ reg - | RegReal (RealRegSingle{}) <- reg - -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - - LD format addr reg - -> hcat [ - text "\tld", - pprFormat format, - char '\t', - lbrack, - pprAddr platform addr, - pp_rbracket_comma, - pprReg reg - ] - - -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand - ST FF64 reg _ - | RegReal (RealRegSingle{}) <- reg - -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" - - -- no distinction is made between signed and unsigned bytes on stores for the - -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), - -- so we call a special-purpose pprFormat for ST.. - ST format reg addr - -> hcat [ - text "\tst", - pprStFormat format, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr platform addr, - rbrack - ] - - - ADD x cc reg1 ri reg2 - | not x && not cc && riZero ri - -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - -> pprRegRIReg platform (if x then text "addx" else text "add") cc reg1 ri reg2 - - - SUB x cc reg1 ri reg2 - | not x && cc && reg2 == g0 - -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ] - - | not x && not cc && riZero ri - -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] - - | otherwise - -> pprRegRIReg platform (if x then text "subx" else text "sub") cc reg1 ri reg2 - - AND b reg1 ri reg2 -> pprRegRIReg platform (text "and") b reg1 ri reg2 - - ANDN b reg1 ri reg2 -> pprRegRIReg platform (text "andn") b reg1 ri reg2 - - OR b reg1 ri reg2 - | not b && reg1 == g0 - -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ] - in case ri of - RIReg rrr | rrr == reg2 -> empty - _ -> doit - - | otherwise - -> pprRegRIReg platform (text "or") b reg1 ri reg2 - - ORN b reg1 ri reg2 -> pprRegRIReg platform (text "orn") b reg1 ri reg2 - - XOR b reg1 ri reg2 -> pprRegRIReg platform (text "xor") b reg1 ri reg2 - XNOR b reg1 ri reg2 -> pprRegRIReg platform (text "xnor") b reg1 ri reg2 - - SLL reg1 ri reg2 -> pprRegRIReg platform (text "sll") False reg1 ri reg2 - SRL reg1 ri reg2 -> pprRegRIReg platform (text "srl") False reg1 ri reg2 - SRA reg1 ri reg2 -> pprRegRIReg platform (text "sra") False reg1 ri reg2 - - RDY rd -> text "\trd\t%y," <> pprReg rd - WRY reg1 reg2 - -> text "\twr\t" - <> pprReg reg1 - <> char ',' - <> pprReg reg2 - <> char ',' - <> text "%y" - - SMUL b reg1 ri reg2 -> pprRegRIReg platform (text "smul") b reg1 ri reg2 - UMUL b reg1 ri reg2 -> pprRegRIReg platform (text "umul") b reg1 ri reg2 - SDIV b reg1 ri reg2 -> pprRegRIReg platform (text "sdiv") b reg1 ri reg2 - UDIV b reg1 ri reg2 -> pprRegRIReg platform (text "udiv") b reg1 ri reg2 - - SETHI imm reg - -> hcat [ - text "\tsethi\t", - pprImm platform imm, - comma, - pprReg reg - ] - - NOP -> text "\tnop" - - FABS format reg1 reg2 - -> pprFormatRegReg (text "fabs") format reg1 reg2 - - FADD format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fadd") format reg1 reg2 reg3 - - FCMP e format reg1 reg2 - -> pprFormatRegReg (if e then text "fcmpe" else text "fcmp") - format reg1 reg2 - - FDIV format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fdiv") format reg1 reg2 reg3 - - FMOV format reg1 reg2 - -> pprFormatRegReg (text "fmov") format reg1 reg2 - - FMUL format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fmul") format reg1 reg2 reg3 - - FNEG format reg1 reg2 - -> pprFormatRegReg (text "fneg") format reg1 reg2 - - FSQRT format reg1 reg2 - -> pprFormatRegReg (text "fsqrt") format reg1 reg2 - - FSUB format reg1 reg2 reg3 - -> pprFormatRegRegReg (text "fsub") format reg1 reg2 reg3 - - FxTOy format1 format2 reg1 reg2 - -> hcat [ - text "\tf", - (case format1 of - II32 -> text "ito" - FF32 -> text "sto" - FF64 -> text "dto" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - (case format2 of - II32 -> text "i\t" - II64 -> text "x\t" - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), - pprReg reg1, comma, pprReg reg2 - ] - - - BI cond b blockid - -> hcat [ - text "\tb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - pdoc platform (blockLbl blockid) - ] - - BF cond b blockid - -> hcat [ - text "\tfb", pprCond cond, - if b then pp_comma_a else empty, - char '\t', - pdoc platform (blockLbl blockid) - ] - - JMP addr -> text "\tjmp\t" <> pprAddr platform addr - JMP_TBL op _ _ -> pprInstr platform (JMP op) - - CALL (Left imm) n _ - -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ] - - CALL (Right reg) n _ - -> hcat [ text "\tcall\t", pprReg reg, comma, int n ] - - --- | Pretty print a RI -pprRI :: Platform -> RI -> SDoc -pprRI platform = \case - RIReg r -> pprReg r - RIImm r -> pprImm platform r - - --- | Pretty print a two reg instruction. -pprFormatRegReg :: SDoc -> Format -> Reg -> Reg -> SDoc -pprFormatRegReg name format reg1 reg2 - = hcat [ - char '\t', - name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - - pprReg reg1, - comma, - pprReg reg2 - ] - - --- | Pretty print a three reg instruction. -pprFormatRegRegReg :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc -pprFormatRegRegReg name format reg1 reg2 reg3 - = hcat [ - char '\t', - name, - (case format of - FF32 -> text "s\t" - FF64 -> text "d\t" - _ -> panic "SPARC.Ppr.pprFormatRegReg: no match"), - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - - --- | Pretty print an instruction of two regs and a ri. -pprRegRIReg :: Platform -> SDoc -> Bool -> Reg -> RI -> Reg -> SDoc -pprRegRIReg platform name b reg1 ri reg2 - = hcat [ - char '\t', - name, - if b then text "cc\t" else char '\t', - pprReg reg1, - comma, - pprRI platform ri, - comma, - pprReg reg2 - ] - -{- -pprRIReg :: SDoc -> Bool -> RI -> Reg -> SDoc -pprRIReg name b ri reg1 - = hcat [ - char '\t', - name, - if b then text "cc\t" else char '\t', - pprRI ri, - comma, - pprReg reg1 - ] --} - -{- -pp_ld_lbracket :: SDoc -pp_ld_lbracket = text "\tld\t[" --} - -pp_rbracket_comma :: SDoc -pp_rbracket_comma = text "]," - - -pp_comma_lbracket :: SDoc -pp_comma_lbracket = text ",[" - - -pp_comma_a :: SDoc -pp_comma_a = text ",a" diff --git a/compiler/GHC/CmmToAsm/SPARC/Regs.hs b/compiler/GHC/CmmToAsm/SPARC/Regs.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Regs.hs +++ /dev/null @@ -1,260 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- ----------------------------------------------------------------------------- - -module GHC.CmmToAsm.SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor -) - -where - - -import GHC.Prelude - -import GHC.Platform.SPARC -import GHC.Platform.Reg -import GHC.Platform.Reg.Class -import GHC.CmmToAsm.Format - -import GHC.Types.Unique -import GHC.Utils.Outputable -import GHC.Utils.Panic - -{- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - rts/include/stg/MachRegs.h for a description of what's going on - here. --} - - --- | Get the standard name for the register with this number. -showReg :: RegNo -> String -showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" - - --- Get the register class of a certain real reg -classOfRealReg :: RealReg -> RegClass -classOfRealReg reg - = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble - - --- | regSqueeze_class reg --- Calculate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. --- -{-# INLINE virtualRegSqueeze #-} -virtualRegSqueeze :: RegClass -> VirtualReg -> Int - -virtualRegSqueeze cls vr - = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> 1 - VirtualRegHi{} -> 1 - _other -> 0 - - RcFloat - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 2 - _other -> 0 - - RcDouble - -> case vr of - VirtualRegF{} -> 1 - VirtualRegD{} -> 1 - _other -> 0 - - -{-# INLINE realRegSqueeze #-} -realRegSqueeze :: RegClass -> RealReg -> Int - -realRegSqueeze cls rr - = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 1 - | otherwise -> 0 - - RealRegPair{} -> 0 - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 2 - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> 0 - | otherwise -> 1 - - RealRegPair{} -> 1 - - --- | All the allocatable registers in the machine, --- including register pairs. -allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] - - --- | Get the regno for this sort of reg -gReg, lReg, iReg, oReg, fReg :: Int -> RegNo - -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs - - --- | Some specific regs used by the code generator. -g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg - -f6 = RegReal (RealRegSingle (fReg 6)) -f8 = RegReal (RealRegSingle (fReg 8)) -f22 = RegReal (RealRegSingle (fReg 22)) -f26 = RegReal (RealRegSingle (fReg 26)) -f27 = RegReal (RealRegSingle (fReg 27)) - --- g0 is always zero, and writes to it vanish. -g0 = RegReal (RealRegSingle (gReg 0)) -g1 = RegReal (RealRegSingle (gReg 1)) -g2 = RegReal (RealRegSingle (gReg 2)) - --- FP, SP, int and float return (from C) regs. -fp = RegReal (RealRegSingle (iReg 6)) -sp = RegReal (RealRegSingle (oReg 6)) -o0 = RegReal (RealRegSingle (oReg 0)) -o1 = RegReal (RealRegSingle (oReg 1)) -f0 = RegReal (RealRegSingle (fReg 0)) -f1 = RegReal (RealRegSingle (fReg 1)) - --- | Produce the second-half-of-a-double register given the first half. -{- -fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) - -fPair (VirtualRegD u) - = Just (VirtualRegHi u) - -fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing --} - - --- | All the regs that the register allocator can allocate to, --- with the fixed use regs removed. --- -allocatableRegs :: [RealReg] -allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r -> freeReg r - RealRegPair r1 r2 -> freeReg r1 && freeReg r2 - in filter isFree allRealRegs - - --- | The registers to place arguments for function calls, --- for some number of arguments. --- -argRegs :: RegNo -> [Reg] -argRegs r - = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" - - --- | All the regs that could possibly be returned by argRegs --- -allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] - - --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 --- -callClobberedRegs :: [Reg] -callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) - - - --- | Make a virtual reg with this format. -mkVirtualReg :: Unique -> Format -> VirtualReg -mkVirtualReg u format - | not (isFloatFormat format) - = VirtualRegI u - - | otherwise - = case format of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" - - -regDotColor :: RealReg -> SDoc -regDotColor reg - = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" diff --git a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs b/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs +++ /dev/null @@ -1,74 +0,0 @@ -module GHC.CmmToAsm.SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.Instr -import GHC.CmmToAsm.SPARC.Imm - -import GHC.Cmm.CLabel -import GHC.Cmm.BlockId -import GHC.Cmm - -import GHC.Utils.Panic -import GHC.Utils.Outputable - -data JumpDest - = DestBlockId BlockId - | DestImm Imm - --- Debug Instance -instance Outputable JumpDest where - ppr (DestBlockId bid) = text "blk:" <> ppr bid - ppr (DestImm _bid) = text "imm:?" - -getJumpDestBlockId :: JumpDest -> Maybe BlockId -getJumpDestBlockId (DestBlockId bid) = Just bid -getJumpDestBlockId _ = Nothing - - -canShortcut :: Instr -> Maybe JumpDest -canShortcut _ = Nothing - - -shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump _ other = other - - - -shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics -shortcutStatics fn (CmmStaticsRaw lbl statics) - = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. - -shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel -shortcutLabel fn lab - | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId - | otherwise = lab - -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w) --- slightly dodgy, we're ignoring the second label, but this --- works with the way we use CmmLabelDiffOff for jump tables now. -shortcutStatic _ other_static - = other_static - - -shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel -shortBlockId fn blockid = - case fn blockid of - Nothing -> blockLbl blockid - Just (DestBlockId blockid') -> shortBlockId fn blockid' - Just (DestImm (ImmCLbl lbl)) -> lbl - _other -> panic "shortBlockId" diff --git a/compiler/GHC/CmmToAsm/SPARC/Stack.hs b/compiler/GHC/CmmToAsm/SPARC/Stack.hs deleted file mode 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Stack.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GHC.CmmToAsm.SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots -) - -where - -import GHC.Prelude - -import GHC.CmmToAsm.SPARC.AddrMode -import GHC.CmmToAsm.SPARC.Regs -import GHC.CmmToAsm.SPARC.Base -import GHC.CmmToAsm.SPARC.Imm -import GHC.CmmToAsm.Config - -import GHC.Utils.Outputable -import GHC.Utils.Panic - --- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. --- -spRel :: Int -- ^ stack offset in words, positive or negative - -> AddrMode - -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) - - --- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best --- -fpRel :: Int -> AddrMode -fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) - - --- | Convert a spill slot number to a *byte* offset, with no sign. --- -spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - | slot >= 0 && slot < maxSpillSlots config - = 64 + spillSlotSize * slot - - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots config)) - - --- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. --- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 --- -maxSpillSlots :: NCGConfig -> Int -maxSpillSlots config - = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1 diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -37,7 +37,6 @@ , maxSpillSlots = X86.maxSpillSlots config , allocatableRegs = X86.allocatableRegs platform , ncgAllocMoreStack = X86.allocMoreStack platform - , ncgExpandTop = id , ncgMakeFarBranches = const id , extractUnwindPoints = X86.extractUnwindPoints , invertCondBranches = X86.invertCondBranches diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -513,7 +513,6 @@ interesting :: Platform -> Reg -> Bool interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = freeReg platform i -interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" @@ -754,14 +753,7 @@ DELTA{} -> True _ -> False - - ---- TODO: why is there -- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. --- mkRegRegMoveInstr :: Platform -> Reg diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -295,7 +295,6 @@ RegReal (RealRegSingle i) -> if target32Bit platform then ppr32_reg_no f i else ppr64_reg_no f i - RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u RegVirtual (VirtualRegHi u) -> text "%vHi_" <> pprUniqueAlways u RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -96,17 +96,12 @@ | regNo < firstxmm -> 1 | otherwise -> 0 - RealRegPair{} -> 0 - RcDouble -> case rr of RealRegSingle regNo | regNo >= firstxmm -> 1 | otherwise -> 0 - RealRegPair{} -> 0 - - _other -> 0 -- ----------------------------------------------------------------------------- @@ -249,7 +244,6 @@ | i <= lastint platform -> RcInteger | i <= lastxmm platform -> RcDouble | otherwise -> panic "X86.Reg.classOfRealReg registerSingle too high" - _ -> panic "X86.Regs.classOfRealReg: RegPairs on this arch" -- | Get the name of the register with this number. -- NOTE: fixme, we dont track which "way" the XMM registers are used diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -1113,7 +1113,7 @@ pprAsPtrReg :: CmmReg -> SDoc pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = warnPprTrace (gcp /= VGcPtr) (ppr n) $ char 'R' <> int n <> text ".p" + = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg pprGlobalReg :: GlobalReg -> SDoc @@ -1316,8 +1316,6 @@ bewareLoadStoreAlignment ArchMipsel = True bewareLoadStoreAlignment (ArchARM {}) = True bewareLoadStoreAlignment ArchAArch64 = True - bewareLoadStoreAlignment ArchSPARC = True - bewareLoadStoreAlignment ArchSPARC64 = True -- Pessimistically assume that they will also cause problems -- on unknown arches bewareLoadStoreAlignment ArchUnknown = True diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -192,10 +192,10 @@ -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ = - barrierUnless [ArchX86, ArchX86_64, ArchSPARC] + barrierUnless [ArchX86, ArchX86_64] genCall (PrimTarget MO_WriteBarrier) _ _ = - barrierUnless [ArchX86, ArchX86_64, ArchSPARC] + barrierUnless [ArchX86, ArchX86_64] genCall (PrimTarget MO_Touch) _ _ = return (nilOL, []) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -162,16 +162,17 @@ maybe_strictness_before _ = CoreDoNothing - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_dflags = dflags - , sm_logger = logger - , sm_uf_opts = unfoldingOpts dflags - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True - , sm_pre_inline = pre_inline_on + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_dflags = dflags + , sm_logger = logger + , sm_uf_opts = unfoldingOpts dflags + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_cast_swizzle = True + , sm_inline = True + , sm_case_case = True + , sm_pre_inline = pre_inline_on } simpl_phase phase name iter @@ -690,7 +691,8 @@ -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = warnPprTrace (debugIsOn && (max_iterations > 2)) - ( hang (ppr this_mod <> colon <+> text "simplifier bailing out after" + "Simplifier bailing out" + ( hang (ppr this_mod <> text ", after" <+> int max_iterations <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) @@ -995,7 +997,7 @@ then if hasShortableIdInfo exported_id then True -- See Note [Messing up the exported Id's IdInfo] - else warnPprTrace True (text "Not shorting out:" <+> ppr exported_id) False + else warnPprTrace True "Not shorting out" (ppr exported_id) False else False diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -1703,7 +1703,7 @@ -- and add the tyvars of the Id (if necessary) zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) || not (isEmptyRuleInfo (idSpecialisation v))) - (text "absVarsOf: discarding info on" <+> ppr v) $ + "absVarsOf: discarding info on" (ppr v) $ setIdInfo v vanillaIdInfo | otherwise = v diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -21,7 +21,7 @@ import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) @@ -370,8 +370,8 @@ ; (rhs_floats, body3) <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) - then -- No floating, revert to body1 - return (emptyFloats env, wrapFloats body_floats2 body1) + then -- Do not float; abandon prepareBinding entirely and revert to body1 + return (emptyFloats env, wrapFloats body_floats1 body1) else if null tvs then -- Simple floating {-#SCC "simplLazyBind-simple-floating" #-} @@ -450,15 +450,15 @@ completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $ - do { (prepd_floats, new_rhs) <- prepareBinding env top_lvl new_bndr new_rhs + do { (prepd_floats, prepd_rhs) <- prepareBinding env top_lvl new_bndr new_rhs ; let floats = emptyFloats env `addLetFloats` prepd_floats ; (rhs_floats, rhs2) <- - if doFloatFromRhs NotTopLevel NonRecursive is_strict floats new_rhs + if doFloatFromRhs NotTopLevel NonRecursive is_strict floats prepd_rhs then -- Add the floats to the main env do { tick LetFloatFromLet - ; return (floats, new_rhs) } - else -- Do not float; wrap the floats around the RHS - return (emptyFloats env, wrapFloats floats new_rhs) + ; return (floats, prepd_rhs) } + else -- Do not float; abandon prepareBinding entirely and revert to new_rhs + return (emptyFloats env, new_rhs) ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats) NotTopLevel Nothing @@ -1153,16 +1153,14 @@ simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} - simplLam env zapped_bndrs body cont - -- The main issue here is under-saturated lambdas + simplLam env (zapLambdaBndrs expr n_args) cont + -- zapLambdaBndrs: the issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 -- Here x1 might have "occurs-once" occ-info, because occ-info -- is computed assuming that a group of lambdas is applied -- all at once. If there are too few args, we must zap the -- occ-info, UNLESS the remaining binders are one-shot where - (bndrs, body) = collectBinders expr - zapped_bndrs = zapLamBndrs n_args bndrs n_args = countArgs cont -- NB: countArgs counts all the args (incl type args) -- and likewise drop counts all binders (incl type lambdas) @@ -1191,7 +1189,7 @@ = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont | otherwise - = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont + = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont {- Note [Avoiding space leaks in OutType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1449,12 +1447,12 @@ StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } -> rebuildCall env (addValArgTo fun expr fun_ty ) cont - StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body + StrictBind { sc_bndr = b, sc_body = body , sc_env = se, sc_cont = cont } -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr -- expr satisfies let/app since it started life -- in a call to simplNonRecE - ; (floats2, expr') <- simplLam env' bs body cont + ; (floats2, expr') <- simplLam env' body cont ; return (floats1 `addFloats` floats2, expr') } ApplyToTy { sc_arg_ty = ty, sc_cont = cont} @@ -1598,41 +1596,47 @@ ************************************************************************ -} -simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont +simplLam :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplLam env [] body cont - = simplExprF env body cont +simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont +simplLam env expr cont = simplExprF env expr cont -simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) +simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- Type beta-reduction +simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont } + ; simplLam (extendTvSubst env bndr arg_ty) body cont } -simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_dup = dup }) +-- Value beta-reduction +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup }) | isSimplified dup -- Don't re-simplify if we've simplified it once -- See Note [Avoiding exponential behaviour] = do { tick (BetaReduction bndr) ; (floats1, env') <- simplNonRecX env bndr arg - ; (floats2, expr') <- simplLam env' bndrs body cont + ; (floats2, expr') <- simplLam env' body cont ; return (floats1 `addFloats` floats2, expr') } | otherwise = do { tick (BetaReduction bndr) - ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } + ; simplNonRecE env bndr (arg, arg_se) body cont } - -- Discard a non-counting tick on a lambda. This may change the - -- cost attribution slightly (moving the allocation of the - -- lambda elsewhere), but we don't care: optimisation changes - -- cost attribution all the time. -simplLam env bndrs body (TickIt tickish cont) +-- Discard a non-counting tick on a lambda. This may change the +-- cost attribution slightly (moving the allocation of the +-- lambda elsewhere), but we don't care: optimisation changes +-- cost attribution all the time. +simpl_lam env bndr body (TickIt tickish cont) | not (tickishCounts tickish) - = simplLam env bndrs body cont + = simpl_lam env bndr body cont - -- Not enough args, so there are real lambdas left to put in the result -simplLam env bndrs body cont - = do { (env', bndrs') <- simplLamBndrs env bndrs - ; body' <- simplExpr env' body +-- Not enough args, so there are real lambdas left to put in the result +simpl_lam env bndr body cont + = do { let (inner_bndrs, inner_body) = collectBinders body + ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) + ; body' <- simplExpr env' inner_body ; new_lam <- mkLam env' bndrs' body' cont ; rebuild env' new_lam cont } @@ -1652,8 +1656,7 @@ -> InId -- The binder, always an Id -- Never a join point -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> ([InBndr], InExpr) -- Body of the let/lambda - -- \xs.e + -> InExpr -- Body of the let/lambda -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -1661,27 +1664,22 @@ -- * non-top-level non-recursive non-join-point lets in expressions -- * beta reduction -- --- simplNonRec env b (rhs, rhs_se) (bs, body) k +-- simplNonRec env b (rhs, rhs_se) body k -- = let env in --- cont< let b = rhs_se(rhs) in \bs.body > +-- cont< let b = rhs_se(rhs) in body > -- -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process -- -- Precondition: rhs satisfies the let/app invariant -- Note [Core let/app invariant] in GHC.Core --- --- The "body" of the binding comes as a pair of ([InId],InExpr) --- representing a lambda; so we recurse back to simplLam --- Why? Because of the binder-occ-info-zapping done before --- the call to simplLam in simplExprF (Lam ...) -simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont +simplNonRecE env bndr (rhs, rhs_se) body cont | assert (isId bndr && not (isJoinId bndr) ) True , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se = do { tick (PreInlineUnconditionally bndr) ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam env' bndrs body cont } + simplLam env' body cont } | otherwise = do { (env1, bndr1) <- simplNonRecBndr env bndr @@ -1690,14 +1688,14 @@ -- See Note [Dark corner with representation polymorphism] ; if isStrictId bndr1 && sm_case_case (getMode env) then simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body + (StrictBind { sc_bndr = bndr, sc_body = body , sc_env = env, sc_cont = cont, sc_dup = NoDup }) -- Deal with lazy bindings else do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; (floats2, expr') <- simplLam env3 bndrs body cont + ; (floats2, expr') <- simplLam env3 body cont ; return (floats1 `addFloats` floats2, expr') } } ------------------ @@ -3170,6 +3168,7 @@ addBinderUnfolding env bndr unf | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + "unfolding type mismatch" (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ modifyInScope env (bndr `setIdUnfolding` unf) @@ -3336,7 +3335,7 @@ -- it "sees" that the entire branch of an outer case is -- inaccessible. So we simply put an error case here instead. missingAlt env case_bndr _ cont - = warnPprTrace True (text "missingAlt" <+> ppr case_bndr) $ + = warnPprTrace True "missingAlt" (ppr case_bndr) $ -- See Note [Avoiding space leaks in OutType] let cont_ty = contResultType cont in seqType cont_ty `seq` @@ -3432,14 +3431,14 @@ ; return (floats, TickIt t cont') } mkDupableContWithDmds env _ - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs - , sc_body = body, sc_env = se, sc_cont = cont}) + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = se, sc_cont = cont}) -- See Note [Duplicating StrictBind] -- K[ let x = <> in b ] --> join j x = K[ b ] -- j <> = do { let sb_env = se `setInScopeFromE` env ; (sb_env1, bndr') <- simplBinder sb_env bndr - ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont + ; (floats1, join_inner) <- simplLam sb_env1 body cont -- No need to use mkDupableCont before simplLam; we -- use cont once here, and then share the result if necessary @@ -3564,7 +3563,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] = return (emptyFloats env - , StrictBind { sc_bndr = arg_bndr, sc_bndrs = [] + , StrictBind { sc_bndr = arg_bndr , sc_body = join_rhs , sc_env = zapSubstEnv env -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils @@ -4114,9 +4113,14 @@ eta-expand the stable unfolding to arity N too. Simple and consistent. Wrinkles + +* See Note [Eta-expansion in stable unfoldings] in + GHC.Core.Opt.Simplify.Utils + * Don't eta-expand a trivial expr, else each pass will eta-reduce it, and then eta-expand again. See Note [Do not eta-expand trivial expressions] in GHC.Core.Opt.Simplify.Utils. + * Don't eta-expand join points; see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point case (mb_cont = Just _) doesn't use eta_expand. diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -149,11 +149,10 @@ , sc_cont :: SimplCont } -- The two strict forms have no DupFlag, because we never duplicate them - | StrictBind -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b] - -- or, equivalently, = K[ (\x xs.b) e ] + | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] + -- or, equivalently, = K[ (\x.b) e ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] , sc_bndr :: InId - , sc_bndrs :: [InBndr] , sc_body :: InExpr , sc_env :: StaticEnv -- See Note [StaticEnv invariant] , sc_cont :: SimplCont } @@ -483,9 +482,11 @@ contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- countArgs :: SimplCont -> Int --- Count all arguments, including types, coercions, and other values +-- Count all arguments, including types, coercions, +-- and other values; skipping over casts. countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont +countArgs (CastIt _ cont) = countArgs cont countArgs _ = 0 contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) @@ -568,7 +569,7 @@ else demands ++ vanilla_dmds | otherwise - -> warnPprTrace True (text "More demands than arity" <+> ppr fun <+> ppr (idArity fun) + -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) <+> ppr n_val_args <+> ppr demands) $ vanilla_dmds -- Not enough args, or no strictness @@ -588,9 +589,18 @@ | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds - , let dmd' = case isLiftedType_maybe arg_ty of - Just False -> strictifyDmd dmd - _ -> dmd + , let dmd' + -- TODO: we should just use isLiftedType_maybe, but that + -- function is currently wrong (#20837). + | Just rr <- getRuntimeRep_maybe arg_ty + , Just False <- isLiftedRuntimeRep_maybe rr + -- The type is definitely unlifted, such as: + -- - TYPE (BoxedRep Unlifted) + -- - TYPE IntRep, TYPE FloatRep, ... + = strictifyDmd dmd + | otherwise + -- Could be definitely lifted, or we're not sure (e.g. levity-polymorphic). + = dmd = dmd' : add_type_strictness fun_ty' rest_dmds -- If the type is representation-polymorphic, we can't know whether -- it's strict. isLiftedType_maybe will return Just False only when @@ -880,6 +890,7 @@ -- unboxed tuple stuff that confuses the bytecode -- interpreter , sm_eta_expand = eta_expand_on + , sm_cast_swizzle = True , sm_case_case = True , sm_pre_inline = pre_inline_on } @@ -890,14 +901,14 @@ uf_opts = unfoldingOpts dflags updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode --- See Note [Simplifying inside stable unfoldings] updModeForStableUnfoldings unf_act current_mode = current_mode { sm_phase = phaseFromActivation unf_act - , sm_inline = True - , sm_eta_expand = False } - -- sm_eta_expand: see Note [No eta expansion in stable unfoldings] - -- sm_rules: just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules + , sm_eta_expand = False + , sm_inline = True } + -- sm_phase: see Note [Simplifying inside stable unfoldings] + -- sm_eta_expand: see Note [Eta-expansion in stable unfoldings] + -- sm_rules: just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter _ n) = Phase n phaseFromActivation _ = InitialPhase @@ -905,10 +916,13 @@ updModeForRules :: SimplMode -> SimplMode -- See Note [Simplifying rules] updModeForRules current_mode - = current_mode { sm_phase = InitialPhase - , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False] - , sm_rules = False - , sm_eta_expand = False } + = current_mode { sm_phase = InitialPhase + , sm_inline = False + -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_cast_swizzle = False + -- See Note [Cast swizzling on rule LHSs] + , sm_eta_expand = False } {- Note [Simplifying rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -938,24 +952,39 @@ 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 +Note [Cast swizzling on rule LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the LHS of a RULE we may have + (\x. blah |> CoVar cv) +where `cv` is a coercion variable. Critically, we really only want +coercion /variables/, not general coercions, on the LHS of a RULE. So +we don't want to swizzle this to + (\x. blah) |> (Refl xty `FunCo` CoVar cv) +So we switch off cast swizzling in updModeForRules. +Note [Eta-expansion in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do eta-expansion inside stable unfoldings. It's extra work, +and can be expensive (the bizarre T18223 is a case in point). + +See Note [Occurrence analysis for lambda binders] in GHC.Core.Opt.OccurAnal. + +Historical note. There was /previously/ another reason not to do eta +expansion in stable unfoldings. If we have a stable unfolding + f :: Ord a => a -> IO () -- Unfolding template -- = /\a \(d:Ord a) (x:a). bla -we do not want to eta-expand to +we previously did not want to eta-expand to f :: Ord a => a -> IO () -- Unfolding template -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co -because not specialisation of the overloading doesn't work properly -(see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. +because not specialisation of the overloading didn't work properly (#9509). +But now it does: see Note [Account for casts in binding] in GHC.Core.Opt.Specialise -So we disable eta-expansion in stable unfoldings. Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1564,19 +1593,13 @@ = return body mkLam env bndrs body cont = {-#SCC "mkLam" #-} +-- pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $ do { dflags <- getDynFlags ; mkLam' dflags bndrs body } where - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs (Cast body co) - | not (any bad bndrs) - -- Note [Casts and lambdas] - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + mode = getMode env + mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam' dflags bndrs body@(Lam {}) = mkLam' dflags (bndrs ++ bndrs1) body1 where @@ -1586,19 +1609,30 @@ | tickishFloatable t = mkTick t <$> mkLam' dflags bndrs expr + mkLam' dflags bndrs (Cast body co) + | -- Note [Casts and lambdas] + sm_cast_swizzle mode + , not (any bad bndrs) + = do { lam <- mkLam' dflags bndrs body + ; return (mkCast lam (mkPiCos Representational bndrs co)) } + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + mkLam' dflags bndrs body | gopt Opt_DoEtaReduction dflags - , Just etad_lam <- tryEtaReduce bndrs body + , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } | not (contIsRhs cont) -- See Note [Eta-expanding lambdas] - , sm_eta_expand (getMode env) + , sm_eta_expand mode , any isRuntimeVar bndrs - , let body_arity = exprEtaExpandArity dflags body + , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body , expandableArityType body_arity = do { tick (EtaExpansion (head bndrs)) - ; let res = mkLams bndrs $ + ; let res = {-# SCC "eta3" #-} + mkLams bndrs $ etaExpandAT in_scope body_arity body ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) , text "after" <+> ppr res]) @@ -1629,7 +1663,7 @@ guard. NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Note [No eta expansion in stable unfoldings] + See Note [Eta-expansion in stable unfoldings] Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1649,19 +1683,25 @@ /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) (if not (g `in` co)) -Notice that it works regardless of 'e'. Originally it worked only -if 'e' was itself a lambda, but in some cases that resulted in -fruitless iteration in the simplifier. A good example was when -compiling Text.ParserCombinators.ReadPrec, where we had a definition -like (\x. Get `cast` g) -where Get is a constructor with nonzero arity. Then mkLam eta-expanded -the Get, and the next iteration eta-reduced it, and then eta-expanded -it again. +We call this "cast swizzling". It is controlled by sm_cast_swizzle. +See also Note [Cast swizzling on rule LHSs] -Note also the side condition for the case of coercion binders. -It does not make sense to transform - /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) -because the latter is not well-kinded. +Wrinkles + +* Notice that it works regardless of 'e'. Originally it worked only + if 'e' was itself a lambda, but in some cases that resulted in + fruitless iteration in the simplifier. A good example was when + compiling Text.ParserCombinators.ReadPrec, where we had a definition + like (\x. Get `cast` g) + where Get is a constructor with nonzero arity. Then mkLam eta-expanded + the Get, and the next iteration eta-reduced it, and then eta-expanded + it again. + +* Note also the side condition for the case of coercion binders, namely + not (any bad bndrs). It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) + because the latter is not well-kinded. + ************************************************************************ * * diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -2226,8 +2226,8 @@ ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ warnPprTrace (not (isEmptyVarSet bad_covars)) - ( text "SpecConstr: bad covars:" <+> ppr bad_covars - $$ ppr call) $ + "SpecConstr: bad covars" + (ppr bad_covars $$ ppr call) $ if interesting && isEmptyVarSet bad_covars then -- pprTraceM "callToPatsOut" ( @@ -2530,7 +2530,7 @@ same e1 (Tick _ e2) = same e1 e2 same e1 (Cast e2 _) = same e1 e2 - same e1 e2 = warnPprTrace (bad e1 || bad e2) (ppr e1 $$ ppr e2) $ + same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $ False -- Let, lambda, case should not occur bad (Case {}) = True bad (Let {}) = True diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1442,7 +1442,7 @@ | otherwise -- No calls or RHS doesn't fit our preconceptions = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me) - (text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc) $ + "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $ -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) @@ -2064,6 +2064,8 @@ Reason: when specialising the body for a call (f ty dexp), we want to substitute dexp for d, and pick up specialised calls in the body of f. + +We do allow casts, however; see Note [Account for casts in binding]. This doesn't always work. One example I came across was this: newtype Gen a = MkGen{ unGen :: Int -> a } diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -723,6 +723,7 @@ splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) + "splitFun" (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr ; case mb_stuff of diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -280,8 +280,8 @@ too_many_args_for_join_point wrap_args | Just join_arity <- mb_join_arity , wrap_args `lengthExceeds` join_arity - = warnPprTrace True (text "Unable to worker/wrapper join point with arity " <+> - int join_arity <+> text "but" <+> + = warnPprTrace True "Unable to worker/wrapper join point" + (text "arity" <+> int join_arity <+> text "but" <+> int (length wrap_args) <+> text "args") $ True | otherwise @@ -610,7 +610,7 @@ where -- | See Note [non-algebraic or open body type warning] - open_body_ty_warning = warnPprTrace True (text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty) Nothing + open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -620,7 +620,7 @@ stg_arg_rep = typePrimRep (stgArgType stg_arg) bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) - warnPprTrace bad_args (text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg) $ + warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $ return (stg_arg : stg_args, ticks ++ aticks) coreToStgTick :: Type -- type of the ticked expression @@ -725,7 +725,7 @@ -- so this is not a function binding | StgConApp con mn args _ <- unticked_rhs , -- Dynamic StgConApps are updatable - not (isDllConApp dflags this_mod con args) + not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args) = -- CorePrep does this right, but just to make sure assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) (ppr bndr $$ ppr con $$ ppr args) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -30,6 +30,7 @@ import GHC.Builtin.Names import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Builtin.Types import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) @@ -67,7 +68,7 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId ) +import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) @@ -657,7 +658,7 @@ ; (floats3, rhs3) <- if manifestArity rhs1 <= arity then return (floats2, cpeEtaExpand arity rhs2) - else warnPprTrace True (text "CorePrep: silly extra arguments:" <+> ppr bndr) $ + else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) ; let float = mkFloat topDmd False v rhs2 @@ -791,7 +792,8 @@ ; return (bind_floats `appendFloats` body_floats, expr') } cpeRhsE env (Tick tickish expr) - | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope + -- Pull out ticks if they are allowed to be floated. + | floatableTick tickish = do { (floats, body) <- cpeRhsE env expr -- See [Floating Ticks in CorePrep] ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } @@ -945,11 +947,50 @@ ppr (CpeCast co) = text "cast" <+> ppr co ppr (CpeTick tick) = text "tick" <+> ppr tick +{- Note [Ticks and mandatory eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something like + `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool` +caused a compiler panic in #20938. Why did this happen? +The simplifier will eta-reduce the rhs giving us a partial +application of tagToEnum#. The tick is then pushed inside the +type argument. That is we get + `(Tick tagToEnum#) @Bool` +CorePrep would go on to see a undersaturated tagToEnum# application +and eta expand the expression under the tick. Giving us: + (Tick (\forall a. x -> tagToEnum# @a x) @Bool +Suddenly tagToEnum# is applied to a polymorphic type and the code generator +panics as it needs a concrete type to determine the representation. + +The problem in my eyes was that the tick covers a partial application +of a primop. There is no clear semantic for such a construct as we can't +partially apply a primop since they do not have bindings. +We fix this by expanding the scope of such ticks slightly to cover the body +of the eta-expanded expression. + +We do this by: +* Checking if an application is headed by a primOpish thing. +* If so we collect floatable ticks and usually but also profiling ticks + along with regular arguments. +* When rebuilding the application we check if any profiling ticks appear + before the primop is fully saturated. +* If the primop isn't fully satured we eta expand the primop application + and scope the tick to scope over the body of the saturated expression. + +Going back to #20938 this means starting with + `(Tick tagToEnum#) @Bool` +we check if the function head is a primop (yes). This means we collect the +profiling tick like if it was floatable. Giving us + (tagToEnum#, [CpeTick foo, CpeApp @Bool]). +cpe_app filters out the tick as a underscoped tick on the expression +`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the +body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. +-} cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops cpeApp top_env expr - = do { let (terminal, args, depth) = collect_args expr - ; cpe_app top_env terminal args depth + = do { let (terminal, args) = collect_args expr + ; cpe_app top_env terminal args } where @@ -960,26 +1001,34 @@ -- record casts and ticks. Depth counts the number -- of arguments that would consume strictness information -- (so, no type or coercion arguments.) - collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int) - collect_args e = go e [] 0 + collect_args :: CoreExpr -> (CoreExpr, [ArgInfo]) + collect_args e = go e [] where - go (App fun arg) as !depth + go (App fun arg) as = go fun (CpeApp arg : as) - (if isTyCoArg arg then depth else depth + 1) - go (Cast fun co) as depth - = go fun (CpeCast co : as) depth - go (Tick tickish fun) as depth - | tickishPlace tickish == PlaceNonLam - && tickish `tickishScopesLike` SoftScope - = go fun (CpeTick tickish : as) depth - go terminal as depth = (terminal, as, depth) + go (Cast fun co) as + = go fun (CpeCast co : as) + go (Tick tickish fun) as + -- Profiling ticks are slightly less strict so we expand their scope + -- if they cover partial applications of things like primOps. + -- See Note [Ticks and mandatory eta expansion] + | floatableTick tickish || isProfTick tickish + , Var vh <- head + , Var head' <- lookupCorePrepEnv top_env vh + , hasNoBinding head' + = (head,as') + where + (head,as') = go fun (CpeTick tickish : as) + -- Terminal could still be an app if it's wrapped by a tick. + -- E.g. Tick (f x) can give us (f x) as terminal. + go terminal as = (terminal, as) + cpe_app :: CorePrepEnv -> CoreExpr -> [ArgInfo] - -> Int -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth + cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey -- Replace (noinline a) with a @@ -998,14 +1047,13 @@ -- } -- -- rather than the far superior "f x y". Test case is par01. - = let (terminal, args', depth') = collect_args arg - in cpe_app env terminal (args' ++ args) (depth + depth' - 1) + = let (terminal, args') = collect_args arg + in cpe_app env terminal (args' ++ args) -- See Note [keepAlive# magic]. cpe_app env (Var f) args - n | Just KeepAliveOp <- isPrimOpId_maybe f , CpeApp (Type arg_rep) : CpeApp (Type arg_ty) @@ -1019,9 +1067,9 @@ ; s2 <- newVar realWorldStatePrimTy ; -- beta reduce if possible ; (floats, k') <- case k of - Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2) - _ -> cpe_app env k (CpeApp s0 : rest) (n-1) - ; let touchId = mkPrimOpId TouchOp + Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest + _ -> cpe_app env k (CpeApp s0 : rest) + ; let touchId = primOpId TouchOp expr = Case k' y result_ty [Alt DEFAULT [] rhs] rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId] in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)] @@ -1031,31 +1079,37 @@ | Just KeepAliveOp <- isPrimOpId_maybe f = panic "invalid keepAlive# application" - cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n + -- runRW# magic + cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# -- applications, keep in mind that we may have applications that return - , n >= 1 + , has_value_arg (CpeApp arg : rest) -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of - Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest (n-2) - _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) (n-1) + Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest + _ -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest) -- TODO: What about casts? + where + has_value_arg [] = False + has_value_arg (CpeApp arg:_rest) + | not (isTyCoArg arg) = True + has_value_arg (_:rest) = has_value_arg rest - cpe_app env (Var v) args depth + cpe_app env (Var v) args = do { v1 <- fiddleCCall v ; let e2 = lookupCorePrepEnv env v1 hd = getIdFromTrivialExpr_maybe e2 - -- NB: depth from collect_args is right, because e2 is a trivial expression - -- and thus its embedded Id *must* be at the same depth as any - -- Apps it is under are type applications only (c.f. - -- exprIsTrivial). But note that we need the type of the - -- expression, not the id. - ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts - ; mb_saturate hd app floats depth } + -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion] + min_arity = case hd of + Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing + Nothing -> Nothing + ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity + ; mb_saturate hd app floats unsat_ticks depth } where + depth = val_args args stricts = case idDmdSig v of DmdSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands @@ -1069,22 +1123,45 @@ -- We inlined into something that's not a var and has no args. -- Bounce it back up to cpeRhsE. - cpe_app env fun [] _ = cpeRhsE env fun + cpe_app env fun [] = cpeRhsE env fun - -- N-variable fun, better let-bind it - cpe_app env fun args depth + -- Here we get: + -- N-variable fun, better let-bind it + -- This case covers literals, apps, lams or let expressions applied to arguments. + -- Basically things we want to ANF before applying to arguments. + cpe_app env fun args = do { (fun_floats, fun') <- cpeArg env evalDmd fun - -- The evalDmd says that it's sure to be evaluated, - -- so we'll end up case-binding it - ; (app, floats) <- rebuild_app env args fun' fun_floats [] - ; mb_saturate Nothing app floats depth } + -- If evalDmd says that it's sure to be evaluated, + -- we'll end up case-binding it + ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing + ; mb_saturate Nothing app floats unsat_ticks (val_args args) } + -- | Count the number of value arguments. + val_args :: [ArgInfo] -> Int + val_args args = go args 0 + where + go [] !n = n + go (info:infos) n = + case info of + CpeCast {} -> go infos n + CpeTick tickish + | floatableTick tickish -> go infos n + -- If we can't guarantee a tick will be floated out of the application + -- we can't guarantee the value args following it will be applied. + | otherwise -> n + CpeApp e -> go infos n' + where + !n' + | isTyCoArg e = n + | otherwise = n+1 + -- Saturate if necessary - mb_saturate head app floats depth = + mb_saturate head app floats unsat_ticks depth = case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth + Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks ; return (floats, sat_app) } - _other -> return (floats, app) + _other -> do { massert (null unsat_ticks) + ; return (floats, app) } -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, @@ -1097,20 +1174,43 @@ -> CpeApp -> Floats -> [Demand] - -> UniqSM (CpeApp, Floats) - rebuild_app _ [] app floats ss + -> Maybe Arity + -> UniqSM (CpeApp + ,Floats + ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] + ) + rebuild_app env args app floats ss req_depth = + rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth) + + rebuild_app' + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer) + -> CpeApp + -> Floats + -> [Demand] + -> [CoreTickish] + -> Int -- Number of arguments required to satisfy minimal tick scopes. + -> UniqSM (CpeApp, Floats, [CoreTickish]) + rebuild_app' _ [] app floats ss rt_ticks !_req_depth = assert (null ss) -- make sure we used all the strictness info - return (app, floats) + return (app, floats, rt_ticks) - rebuild_app env (a : as) fun' floats ss = case a of + rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of + -- See Note [Ticks and mandatory eta expansion] + _ + | not (null rt_ticks) + , req_depth <= 0 + -> + let tick_fun = foldr mkTick fun' rt_ticks + in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth CpeApp (Type arg_ty) - -> rebuild_app env as (App fun' (Type arg_ty')) floats ss + -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth where arg_ty' = cpSubstTy env arg_ty CpeApp (Coercion co) - -> rebuild_app env as (App fun' (Coercion co')) floats ss + -> rebuild_app' env as (App fun' (Coercion co')) floats ss rt_ticks req_depth where co' = cpSubstCo env co @@ -1121,16 +1221,21 @@ (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, []) (fs, arg') <- cpeArg top_env ss1 arg - rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest + rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1) CpeCast co - -> rebuild_app env as (Cast fun' co') floats ss + -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth where co' = cpSubstCo env co - + -- See Note [Ticks and mandatory eta expansion] CpeTick tickish + | tickishPlace tickish == PlaceRuntime + , req_depth > 0 + -> assert (isProfTick tickish) $ + rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth + | otherwise -- See [Floating Ticks in CorePrep] - -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss + -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in GHC.Types.Id.Make @@ -1424,13 +1529,14 @@ with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. -} -maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs -maybeSaturate fn expr n_args +maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate fn expr n_args unsat_ticks | hasNoBinding fn -- There's no binding - = return sat_expr + = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr | otherwise - = return expr + = assert (null unsat_ticks) $ + return expr where fn_arity = idArity fn excess_arity = fn_arity - n_args @@ -1451,7 +1557,7 @@ Note [Eta expansion] ~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder. Remember, +Eta expand to match the arity claimed by the binder Remember, CorePrep must not change arity Eta expansion might not have happened already, because it is done by @@ -2117,7 +2223,10 @@ wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) - +floatableTick :: GenTickish pass -> Bool +floatableTick tickish = + tickishPlace tickish == PlaceNonLam && + tickish `tickishScopesLike` SoftScope ------------------------------------------------------------------------------ -- Numeric literals diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -336,9 +336,14 @@ -- | Generate code to initialise info pointer origin -- See note [Mapping Info Tables to Source Positions] -ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub -ipInitCode dflags this_mod ents - = if not (gopt Opt_InfoTableMap dflags) +ipInitCode + :: Bool -- is Opt_InfoTableMap enabled or not + -> Platform + -> Module + -> [InfoProvEnt] + -> CStub +ipInitCode do_info_table platform this_mod ents + = if not do_info_table then mempty else CStub $ vcat $ map emit_ipe_decl ents @@ -351,7 +356,6 @@ ]) ] where - platform = targetPlatform dflags emit_ipe_decl ipe = text "extern InfoProvEnt" <+> ipe_lbl <> text "[];" where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe) diff --git a/compiler/GHC/Driver/Config/HsToCore.hs b/compiler/GHC/Driver/Config/HsToCore.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/HsToCore.hs @@ -0,0 +1,19 @@ +module GHC.Driver.Config.HsToCore + ( initBangOpts + ) +where + +import GHC.Types.Id.Make +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + +initBangOpts :: DynFlags -> BangOpts +initBangOpts dflags = BangOpts + { bang_opt_strict_data = xopt LangExt.StrictData dflags + , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags + -- Don't unbox if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , bang_opt_unbox_strict = gopt Opt_UnboxStrictFields dflags + , bang_opt_unbox_small = gopt Opt_UnboxSmallStrictFields dflags + } + diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -0,0 +1,74 @@ +module GHC.Driver.Config.StgToCmm + ( initStgToCmmConfig + ) where + +import GHC.StgToCmm.Config + +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.Platform +import GHC.Platform.Profile +import GHC.Unit.Module +import GHC.Utils.Outputable + +import Data.Maybe +import Prelude + +initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig +initStgToCmmConfig dflags mod = StgToCmmConfig + -- settings + { stgToCmmProfile = profile + , stgToCmmThisModule = mod + , stgToCmmTmpDir = tmpDir dflags + , stgToCmmContext = initSDocContext dflags defaultDumpStyle + , stgToCmmDebugLevel = debugLevel dflags + , stgToCmmBinBlobThresh = binBlobThreshold dflags + , stgToCmmMaxInlAllocSize = maxInlineAllocSize dflags + -- ticky options + , stgToCmmDoTicky = gopt Opt_Ticky dflags + , stgToCmmTickyAllocd = gopt Opt_Ticky_Allocd dflags + , stgToCmmTickyLNE = gopt Opt_Ticky_LNE dflags + , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk dflags + -- flags + , stgToCmmLoopification = gopt Opt_Loopification dflags + , stgToCmmAlignCheck = gopt Opt_AlignmentSanitisation dflags + , stgToCmmOptHpc = gopt Opt_Hpc dflags + , stgToCmmFastPAPCalls = gopt Opt_FastPAPCalls dflags + , stgToCmmSCCProfiling = sccProfilingEnabled dflags + , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags + , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags + , stgToCmmOmitYields = gopt Opt_OmitYields dflags + , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags + , stgToCmmPIC = gopt Opt_PIC dflags + , stgToCmmPIE = gopt Opt_PIE dflags + , stgToCmmExtDynRefs = gopt Opt_ExternalDynamicRefs dflags + , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags + -- backend flags + , stgToCmmAllowBigArith = not ncg + , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc) + , stgToCmmAllowQuotRem2 = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm + , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm + , stgToCmmAllowFabsInstrs = (ncg && (x86ish || ppc || aarch64)) || llvm + -- SIMD flags + , stgToCmmVecInstrsErr = vec_err + , stgToCmmAvx = isAvxEnabled dflags + , stgToCmmAvx2 = isAvx2Enabled dflags + , stgToCmmAvx512f = isAvx512fEnabled dflags + } where profile = targetProfile dflags + platform = profilePlatform profile + bk_end = backend dflags + ncg = bk_end == NCG + llvm = bk_end == LLVM + x86ish = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + _ -> False + ppc = case platformArch platform of + ArchPPC -> True + ArchPPC_64 _ -> True + _ -> False + aarch64 = platformArch platform == ArchAArch64 + vec_err = case backend dflags of + LLVM -> Nothing + _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."]) diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs --- a/compiler/GHC/Driver/GenerateCgIPEStub.hs +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -19,11 +19,12 @@ import GHC.Driver.Env (hsc_dflags) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) +import GHC.Driver.Config.StgToCmm import GHC.Plugins (HscEnv, NonCaffySet) import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (Platform, platformUnregisterised) -import GHC.StgToCmm.Monad (getCmm, initC, runC) +import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) @@ -177,8 +178,9 @@ generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos generateCgIPEStub hsc_env this_mod denv s = do - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env platform = targetPlatform dflags + fstate = initFCodeState platform cgState <- liftIO initC -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. @@ -187,7 +189,7 @@ -- Yield Cmm for Info Table Provenance Entries (IPEs) let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} - ((ipeStub, ipeCmmGroup), _) = runC dflags this_mod cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv' this_mod) + ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv') (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -104,8 +104,9 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput -import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Hooks @@ -1703,12 +1704,13 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath) hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let profile = targetProfile dflags - let hooks = hsc_hooks hsc_env - let tmpfs = hsc_tmpfs hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags + do_info_table = gopt Opt_InfoTableMap dflags -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1736,11 +1738,11 @@ FormatCMM (pdoc platform cmmgroup) rawCmms <- case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) - Just h -> h dflags Nothing (Stream.yield cmmgroup) + Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) let foreign_stubs _ = - let ip_init = ipInitCode dflags cmm_mod ents + let ip_init = ipInitCode do_info_table platform cmm_mod ents in NoStubs `appendStubC` ip_init (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) @@ -1785,17 +1787,17 @@ -- the C-- up front, which has a significant space cost. doCodeGen hsc_env this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info = do - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let hooks = hsc_hooks hsc_env - let tmpfs = hsc_tmpfs hsc_env - let platform = targetPlatform dflags + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + platform = targetPlatform dflags putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) - let stg_to_cmm = case stgToCmmHook hooks of - Nothing -> StgToCmm.codeGen logger tmpfs - Just h -> h + let stg_to_cmm dflags mod = case stgToCmmHook hooks of + Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) + Just h -> h (initStgToCmmConfig dflags mod) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -2663,4 +2663,10 @@ as it should be as we retain a copy of the ModDetails for too long. Where? pruneCache in GHC.Driver.Make +4. No TcGblEnv or TcLclEnv are live after typechecking is completed. + Why? By the time we get to simplification all the data structures from typechecking + should be eliminated. + Where? No one place in the compiler. These leaks can be introduced by not suitable + forcing functions which take a TcLclEnv as an argument. + -} diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -319,16 +319,6 @@ , not $ target32Bit (targetPlatform dflags) ] - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction so we have to make sure that the assembler accepts the - -- instruction set. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. - ++ (if platformArch (targetPlatform dflags) == ArchSPARC - then [GHC.SysTools.Option "-mcpu=v9"] - else []) ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] then [GHC.SysTools.Option "-Qunused-arguments"] else []) @@ -453,17 +443,6 @@ then [ "-DCOMPILING_BASE_PACKAGE" ] else []) - -- We only support SparcV9 and better because V8 lacks an atomic CAS - -- instruction. Note that the user can still override this - -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag - -- regardless of the ordering. - -- - -- This is a temporary hack. See #2872, commit - -- 5bd3072ac30216a505151601884ac88bf404c9f2 - ++ (if platformArch platform == ArchSPARC - then ["-mcpu=v9"] - else []) - -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) then ["-Wimplicit"] @@ -1257,6 +1236,7 @@ (x:_) -> return x -- Note [-fPIC for assembler] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- When compiling .c source file GHC's driver pipeline basically -- does the following two things: -- 1. ${CC} -S 'PIC_CFLAGS' source.c diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/compiler/GHC/Hs/Syn/Type.hs @@ -138,7 +138,7 @@ -- can't use `dataConCantHappen` since they are still present before -- than in the typechecked AST. hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top -hsExprType (HsStatic _ e) = lhsExprType e +hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -859,10 +859,10 @@ = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | Just (fn_id, args) <- decompose fun2 args2 , let extra_bndrs = mk_extra_bndrs fn_id args - = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs -- , text "orig_lhs:" <+> ppr orig_lhs -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs + -- , text "extra_bndrs:" <+> ppr extra_bndrs -- , text "fn_id:" <+> ppr fn_id -- , text "args:" <+> ppr args]) $ Right (orig_bndrs ++ extra_bndrs, fn_id, args) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -418,9 +418,9 @@ g = ... makeStatic loc f ... -} -dsExpr (HsStatic _ expr@(L loc _)) = do +dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do expr_ds <- dsLExpr expr - let ty = exprType expr_ds + let (_, [ty]) = splitTyConApp whole_ty makeStaticId <- dsLookupGlobalId makeStaticName dflags <- getDynFlags diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -97,14 +97,13 @@ = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args (ccall_result_ty, res_wrapper) <- boxResult result_ty uniq <- newUnique - dflags <- getDynFlags let target = StaticTarget NoSourceText lbl Nothing True the_fcall = CCall (CCallSpec target CCallConv may_gc) - the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty + the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) -mkFCall :: DynFlags -> Unique -> ForeignCall +mkFCall :: Unique -> ForeignCall -> [CoreExpr] -- Args -> Type -- Result type -> CoreExpr @@ -117,7 +116,7 @@ -- Here we build a ccall thus -- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr)) -- a b s x c -mkFCall dflags uniq the_fcall val_args res_ty +mkFCall uniq the_fcall val_args res_ty = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args where @@ -125,7 +124,7 @@ body_ty = (mkVisFunTysMany arg_tys res_ty) tyvars = tyCoVarsOfTypeWellScoped body_ty ty = mkInfForAllTys tyvars body_ty - the_fcall_id = mkFCallId dflags uniq the_fcall ty + the_fcall_id = mkFCallId uniq the_fcall ty unboxArg :: CoreExpr -- The supplied argument, not representation-polymorphic -> DsM (CoreExpr, -- To pass as the actual argument diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -283,7 +283,7 @@ -- Build the worker worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) tvs = map binderVar tv_bndrs - the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty + the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty @@ -326,9 +326,8 @@ args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism ccall_uniq <- newUnique - dflags <- getDynFlags let - call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty + call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty rhs = mkLams tvs (mkLams args call_app) rhs' = Cast rhs co return ([(fn_id, rhs')], mempty, mempty) diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -203,11 +203,11 @@ } extendIfaceIdEnv :: [Id] -> IfL a -> IfL a -extendIfaceIdEnv ids thing_inside - = do { env <- getLclEnv - ; let { id_env' = extendFsEnvList (if_id_env env) pairs - ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } - ; setLclEnv (env { if_id_env = id_env' }) thing_inside } +extendIfaceIdEnv ids + = updLclEnv $ \env -> + let { id_env' = extendFsEnvList (if_id_env env) pairs + ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } + in env { if_id_env = id_env' } tcIfaceTyVar :: FastString -> IfL TyVar @@ -232,11 +232,11 @@ ; return (lookupFsEnv (if_tv_env lcl) occ) } extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a -extendIfaceTyVarEnv tyvars thing_inside - = do { env <- getLclEnv - ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs - ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } - ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } +extendIfaceTyVarEnv tyvars + = updLclEnv $ \env -> + let { tv_env' = extendFsEnvList (if_tv_env env) pairs + ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } + in env { if_tv_env = tv_env' } extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a extendIfaceEnvs tcvs thing_inside diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -737,7 +737,6 @@ HsLet _ _ _ _ body -> computeLType body RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e - HsStatic _ e -> computeLType e HsPragE _ _ e -> computeLType e XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e XExpr (HsTick _ e) -> computeLType e diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -540,7 +540,7 @@ -- of one's own boot file! (one-shot only) -- See Note [Loading your own hi-boot file] - ; warnPprTrace bad_boot (ppr mod) $ + ; warnPprTrace bad_boot "loadInterface" (ppr mod) $ updateEps_ $ \ eps -> if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface then eps diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -162,7 +162,7 @@ update_decl (IfaceId nm ty details infos) | let not_caffy = elemNameSet nm non_cafs , let mb_lf_info = lookupNameEnv lf_infos nm - , warnPprTrace (isNothing mb_lf_info) (text "Name without LFInfo:" <+> ppr nm) True + , warnPprTrace (isNothing mb_lf_info) "Name without LFInfo" (ppr nm) True -- Only allocate a new IfaceId if we're going to update the infos , isJust mb_lf_info || not_caffy = IfaceId nm ty details $ diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -763,7 +763,7 @@ -- unfolding in the *definition*; so look up in binder_set refined_id = case lookupVarSet binder_set idocc of Just id -> id - Nothing -> warnPprTrace True (ppr idocc) idocc + Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) referrer' | isExportedId refined_id = refined_id @@ -1290,7 +1290,7 @@ sig = dmdSigInfo idinfo final_sig | not $ isTopSig sig - = warnPprTrace (_bottom_hidden sig) (ppr name) sig + = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig -- try a cheap-and-cheerful bottom analyser | Just (_, nsig) <- mb_bot_str = nsig | otherwise = sig diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1102,15 +1102,15 @@ ; prom_rep_name <- newTyConRepName dc_name + ; let bang_opts = FixedBangOpts stricts + -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon; + -- it'll use these to guide the construction of a worker. + -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) + bang_opts dc_name is_infix prom_rep_name (map src_strict if_src_stricts) - (Just stricts) - -- Pass the HsImplBangs (i.e. final - -- decisions) to buildDataCon; it'll use - -- these to guide the construction of a - -- worker. - -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make lbl_names univ_tvs ex_tvs user_tv_bndrs eq_spec theta @@ -1471,8 +1471,7 @@ tcIfaceExpr (IfaceFCall cc ty) = do ty' <- tcIfaceType ty u <- newUnique - dflags <- getDynFlags - return (Var (mkFCallId dflags u cc ty')) + return (Var (mkFCallId u cc ty')) tcIfaceExpr (IfaceTuple sort args) = do { args' <- mapM tcIfaceExpr args diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -70,7 +70,9 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain +#if defined(CAN_LOAD_DLL) import GHC.Utils.Constants (isWindowsHost, isDarwinHost) +#endif import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -1310,11 +1312,13 @@ -- of DLL handles that rts/Linker.c maintains, and that in turn is -- used by lookupSymbol. So we must call addDLL for each library -- just to get the DLL handle into the list. +#if defined(CAN_LOAD_DLL) partOfGHCi :: [PackageName] partOfGHCi | isWindowsHost || isDarwinHost = [] | otherwise = map (PackageName . mkFastString) ["base", "template-haskell", "editline"] +#endif showLS :: LibrarySpec -> String showLS (Objects nms) = "(static) [" ++ intercalate ", " nms ++ "]" @@ -1413,7 +1417,9 @@ -- Complication: all the .so's must be loaded before any of the .o's. let known_dlls = [ dll | DLLPath dll <- classifieds ] +#if defined(CAN_LOAD_DLL) dlls = [ dll | DLL dll <- classifieds ] +#endif objs = [ obj | Objects objs <- classifieds , obj <- objs ] archs = [ arch | Archive arch <- classifieds ] @@ -1504,6 +1510,7 @@ restriction very easily. -} +#if defined(CAN_LOAD_DLL) -- we have already searched the filesystem; the strings passed to load_dyn -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, @@ -1542,6 +1549,7 @@ Nothing -> return () Just err -> cmdLineErrorIO ("can't load framework: " ++ fw ++ " (" ++ err ++ ")" ) +#endif -- Try to find an object file for a given library in the given paths. -- If it isn't present, we assume that addDLL in the RTS can find it, @@ -1635,28 +1643,34 @@ hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags) hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name +#if defined(CAN_LOAD_DLL) so_name = platformSOName platform lib lib_so_name = "lib" ++ so_name dyn_lib_file = case (arch, os) of (ArchX86_64, OSSolaris2) -> "64" so_name _ -> so_name +#endif findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file findDynObject = liftM (fmap $ Objects . (:[])) $ findFile dirs dyn_obj_file findArchive = let local name = liftM (fmap Archive) $ findFile dirs name in apply (map local arch_files) findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file +#if defined(CAN_LOAD_DLL) findDll re = let dirs' = if re == user then lib_dirs else gcc_dirs in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary interp so_name +#endif tryGcc = let search = searchForLibUsingGcc logger dflags +#if defined(CAN_LOAD_DLL) dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs full = dllpath $ search lib_so_name lib_dirs + dlls = [short, full] +#endif gcc name = liftM (fmap Archive) $ search name lib_dirs files = import_libs ++ arch_files - dlls = [short, full] archives = map gcc files in apply $ #if defined(CAN_LOAD_DLL) @@ -1698,7 +1712,9 @@ else apply xs platform = targetPlatform dflags +#if defined(CAN_LOAD_DLL) arch = platformArch platform +#endif os = platformOS platform searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -218,7 +218,8 @@ -- like -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog -- on x86. - ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && + ++ (if not (gopt Opt_CompactUnwind dflags) && + toolSettings_ldSupportsCompactUnwind toolSettings' && not staticLink && (platformOS platform == OSDarwin) && case platformArch platform of diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -73,6 +73,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail +import GHC.Types.Hint import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface @@ -97,10 +98,9 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either ( partitionEithers ) -import Data.List ( find, sortBy ) +import Data.List ( find ) import qualified Data.List.NonEmpty as NE import Control.Arrow ( first ) -import Data.Function import GHC.Types.FieldLabel import GHC.Data.Bag import GHC.Types.PkgQual @@ -300,7 +300,7 @@ -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either SDoc Name) +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of @@ -341,28 +341,12 @@ ; th_topnames <- readTcRef th_topnames_var ; if name `elemNameSet` th_topnames then return (Right name) - else return (Left (exactNameErr name)) + else return (Left (NoExactName name)) } } - gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] - } -sameNameErr :: [GlobalRdrElt] -> SDoc -sameNameErr [] = panic "addSameNameErr: empty list" -sameNameErr gres@(_ : _) - = hang (text "Same exact name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names) $$ th_hint) - where - sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - - th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," - , text "perhaps via newName, in different name-spaces." - , text "If that's it, then -ddump-splices might be useful" ] - + gres -> return (Left (SameName gres)) -- Ugh! See Note [Template Haskell ambiguity] + } ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name @@ -393,7 +377,7 @@ -- when it's used cls doc rdr ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr err) ; return (mkUnboundNameRdr rdr) } Right nm -> return nm } where @@ -441,7 +425,7 @@ ; case men of FoundExactOrOrig n -> return (res n) ExactOrOrigError e -> - do { addErr (TcRnUnknownMessage $ mkPlainError noHints e) + do { addErr (mkTcRnNotInScope rdr_name e) ; return (res (mkUnboundNameRdr rdr_name)) } NotExactOrOrig -> k } @@ -457,9 +441,9 @@ NotExactOrOrig -> k } data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError SDoc -- ^ The RdrName was an Exact - -- or Orig, but there was an - -- error looking up the Name + | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name | NotExactOrOrig -- ^ The RdrName is neither an Exact nor -- Orig @@ -848,7 +832,7 @@ -> Name -- Parent -> SDoc -> RdrName - -> RnM (Either SDoc Name) + -> RnM (Either NotInScopeError Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do @@ -857,12 +841,12 @@ -- This happens for built-in classes, see mod052 for example lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name case res of - NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) + NameNotFound -> return (Left (UnknownSubordinate doc)) FoundChild _p child -> return (Right (greNameMangledName child)) IncorrectParent {} -- See [Mismatched class methods and associated type families] -- in TcInstDecls. - -> return $ Left (unknownSubordinateErr doc rdr_name) + -> return $ Left (UnknownSubordinate doc) {- Note [Family instance binders] @@ -1087,17 +1071,14 @@ -- Maybe it's the name of a *data* constructor = do { data_kinds <- xoptM LangExt.DataKinds ; star_is_type <- xoptM LangExt.StarIsType - ; let star_info = starInfo star_is_type rdr_name + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + star_is_type_hints = noStarIsTypeHints is_star_type rdr_name ; if data_kinds then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of - Nothing -> unboundNameX looking_for rdr_name star_info + Nothing -> unboundNameX looking_for rdr_name star_is_type_hints Just demoted_name -> - do { let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors) - noHints - (untickedPromConstrWarn demoted_name) - ; addDiagnostic msg + do { addDiagnostic $ TcRnUntickedPromotedConstructor demoted_name ; return demoted_name } } else do { -- We need to check if a data constructor of this name is -- in scope to give good error messages. However, we do @@ -1105,8 +1086,11 @@ -- constructor happens to be out of scope! See #13947. mb_demoted_name <- discardErrs $ lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name = suggest_dk - | otherwise = star_info + ; let suggestion | isJust mb_demoted_name + , let additional = text "to refer to the data constructor of that name?" + = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] + | otherwise + = star_is_type_hints ; unboundNameX looking_for rdr_name suggestion } } | otherwise @@ -1114,14 +1098,6 @@ where looking_for = LF WL_Constructor WL_Anywhere - suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" - untickedPromConstrWarn name = - text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot - $$ - hsep [ text "Use" - , quotes (char '\'' <> ppr name) - , text "instead of" - , quotes (ppr name) <> dot ] -- If the given RdrName can be promoted to the type level and its promoted variant is in scope, -- lookup_promoted returns the corresponding type-level Name. @@ -1822,7 +1798,7 @@ = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr_name err) ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } @@ -1835,13 +1811,13 @@ = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr_name err) ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either SDoc Name) + -> RdrName -> RnM (Either NotInScopeError Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- @@ -1903,32 +1879,24 @@ | otherwise -> bale_out_with local_msg Nothing -> bale_out_with candidates_msg } - bale_out_with msg - = return (Left (sep [ text "The" <+> what - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding"] - $$ nest 2 msg)) + bale_out_with hints = return (Left $ MissingBinding what hints) - local_msg = parens $ text "The" <+> what <+> text "must be given where" - <+> quotes (ppr rdr_name) <+> text "is declared" + local_msg = [SuggestMoveToDeclarationSite what rdr_name] -- Identify all similar names and produce a message listing them - candidates :: [Name] -> SDoc + candidates :: [Name] -> [GhcHint] candidates names_in_scope - = case similar_names of - [] -> Outputable.empty - [n] -> text "Perhaps you meant" <+> pp_item n - _ -> sep [ text "Perhaps you meant one of these:" - , nest 2 (pprWithCommas pp_item similar_names) ] + | (nm : nms) <- map SimilarName similar_names + = [SuggestSimilarNames rdr_name (nm NE.:| nms)] + | otherwise + = [] where similar_names = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) names_in_scope - pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) - --------------- lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable. @@ -1939,7 +1907,7 @@ = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) ; let (errs, names) = partitionEithers mb_gres ; when (null names) $ - addErr (TcRnUnknownMessage $ mkPlainError noHints (head errs)) -- Bleat about one only + addErr (head errs) -- Bleat about one only ; return names } where lookup rdr = do { this_mod <- getModule @@ -1950,10 +1918,11 @@ guard_builtin_syntax this_mod rdr (Right name) | Just _ <- isBuiltInOcc_maybe (occName rdr) , this_mod /= nameModule name - = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr]) + = Left $ TcRnIllegalBuiltinSyntax what rdr | otherwise = Right (rdr, name) - guard_builtin_syntax _ _ (Left err) = Left err + guard_builtin_syntax _ _ (Left err) + = Left $ mkTcRnNotInScope rdr_name err dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -51,12 +51,12 @@ import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext , mapFvRn, pprHsDocContext, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN - , checkShadowedRdrNames - , warnForallIdentifier ) + , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr ( pprScopeError ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -752,10 +752,11 @@ check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name + -- TODO: refactor this to avoid TcRnUnknownMessage when (isNothing mb_name) $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext (rtke_ctxt env) $ - notInScopeErr WL_LocalOnly rdr_name + pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name) rnHsTyKi env ty@(HsExplicitListTy _ ip tys) = do { data_kinds <- xoptM LangExt.DataKinds diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -31,10 +31,9 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns - , warnForallIdentifier , newLocalBndrsRn , withHsDocContext, noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars ) + , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types @@ -68,6 +67,7 @@ import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt +import GHC.Tc.Errors.Ppr (pprScopeError) import Control.Monad import Control.Arrow ( first ) @@ -126,7 +126,7 @@ (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; - setEnvs tc_envs $ do { + restoreEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -154,7 +154,7 @@ -- They are already in scope traceRn "rnSrcDecls" (ppr id_bndrs) ; tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; - setEnvs tc_envs $ do { + restoreEnvs tc_envs $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -1353,9 +1353,12 @@ $$ text "LHS must be of form (f e1 .. en) where f is not forall'd" where - err = case bad_e of - HsUnboundVar _ uv -> notInScopeErr WL_Global (mkRdrUnqual uv) - _ -> text "Illegal expression:" <+> ppr bad_e + err = + case bad_e of + HsUnboundVar _ uv -> + let rdr = mkRdrUnqual uv + in pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv) + _ -> text "Illegal expression:" <+> ppr bad_e {- ************************************************************** * * @@ -2437,7 +2440,7 @@ ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls final_gbl_env = gbl_env { tcg_field_env = field_env' } - ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -371,7 +371,7 @@ -- Compiler sanity check: if the import didn't say -- {-# SOURCE #-} we should not get a hi-boot file - warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) (ppr imp_mod_name) $ do + warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do -- Issue a user warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before @@ -891,7 +891,7 @@ (tyClGroupTyClDecls tycl_decls) ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env - ; setEnvs envs $ do { + ; restoreEnvs envs $ do { -- Bring these things into scope first -- See Note [Looking up family names in family instances] diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -53,10 +53,10 @@ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames - , warnUnusedMatches, warnForallIdentifier + , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames - , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit ) + , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Avail ( greNameMangledName ) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -123,6 +123,7 @@ rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket outer_stage br@(VarBr x flg rdr_name) = do { name <- lookupOccRn (unLoc rdr_name) + ; check_namespace flg name ; this_mod <- getModule ; when (flg && nameIsLocalOrFrom this_mod name) $ @@ -184,6 +185,15 @@ rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr x e', fvs) } + +-- | Ensure that we are not using a term-level name in a type-level namespace +-- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem. +check_namespace :: Bool -> Name -> RnM () +check_namespace is_single_tick nm + = unless (isValNameSpace ns == is_single_tick) $ + failWithTc $ (TcRnIncorrectNameSpace nm True) + where + ns = nameNameSpace nm quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + {- This module contains helper functions for reporting and creating @@ -18,7 +20,6 @@ , unboundNameX , notInScopeErr , nameSpacesRelated - , exactNameErr ) where @@ -30,7 +31,6 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) -import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Data.Maybe @@ -38,7 +38,10 @@ import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Error +import GHC.Types.Hint + ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames) + , LanguageExtensionHint (SuggestSingleExtension) + , ImportSuggestion(..), SimilarName(..), HowInScope(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader @@ -48,9 +51,12 @@ import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo +import GHC.Data.Bag +import GHC.Utils.Outputable (empty) + import Data.List (sortBy, partition, nub) +import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on ) -import GHC.Data.Bag {- ************************************************************************ @@ -96,113 +102,89 @@ reportUnboundName = reportUnboundName' WL_Anything unboundName :: LookingFor -> RdrName -> RnM Name -unboundName lf rdr = unboundNameX lf rdr Outputable.empty +unboundName lf rdr = unboundNameX lf rdr [] -unboundNameX :: LookingFor -> RdrName -> SDoc -> RnM Name -unboundNameX looking_for rdr_name extra +unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameX looking_for rdr_name hints = do { dflags <- getDynFlags ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - err = notInScopeErr (lf_where looking_for) rdr_name $$ extra + err = notInScopeErr (lf_where looking_for) rdr_name ; if not show_helpful_errors - then addErr (TcRnUnknownMessage $ mkPlainError noHints err) + then addErr $ TcRnNotInScope err rdr_name [] hints else do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv ; impInfo <- getImports ; currmod <- getModule ; hpt <- getHpt - ; let suggestions = unknownNameSuggestions_ looking_for - dflags hpt currmod global_env local_env impInfo - rdr_name - ; addErr (TcRnUnknownMessage $ mkPlainError noHints (err $$ suggestions)) } + ; let (imp_errs, suggs) = + unknownNameSuggestions_ looking_for + dflags hpt currmod global_env local_env impInfo + rdr_name + ; addErr $ + TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) } ; return (mkUnboundNameRdr rdr_name) } -notInScopeErr :: WhereLooking -> RdrName -> SDoc -notInScopeErr where_look rdr_name - | Just name <- isExact_maybe rdr_name = exactNameErr name - | WL_LocalTop <- where_look = hang (text "No top-level binding for") - 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") - | otherwise = hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) -type HowInScope = Either SrcSpan ImpDeclSpec - -- Left loc => locally bound at loc - -- Right ispec => imported as specified by ispec - +notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError +notInScopeErr where_look rdr_name + | Just name <- isExact_maybe rdr_name + = NoExactName name + | WL_LocalTop <- where_look + = NoTopLevelBinding + | otherwise + = NotInScope -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable unknownNameSuggestions :: WhatLooking -> DynFlags -> HomePackageTable -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc + -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) unknownNameSuggestions_ :: LookingFor -> DynFlags -> HomePackageTable -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc + -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env - imports tried_rdr_name = - similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name $$ - importSuggestions looking_for global_env hpt - curr_mod imports tried_rdr_name $$ - extensionSuggestions tried_rdr_name $$ - fieldSelectorSuggestions global_env tried_rdr_name + imports tried_rdr_name = (imp_errs, suggs) + where + suggs = mconcat + [ if_ne (SuggestSimilarNames tried_rdr_name) $ + similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name + , map ImportSuggestion imp_suggs + , extensionSuggestions tried_rdr_name + , fieldSelectorSuggestions global_env tried_rdr_name ] + (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name + if_ne :: (NonEmpty a -> b) -> [a] -> [b] + if_ne _ [] = [] + if_ne f (a : as) = [f (a :| as)] + -- | When the name is in scope as field whose selector has been suppressed by -- NoFieldSelectors, display a helpful message explaining this. -fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc +fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint] fieldSelectorSuggestions global_env tried_rdr_name - | null gres = Outputable.empty - | otherwise = text "NB:" - <+> quotes (ppr tried_rdr_name) - <+> text "is a field selector" <+> whose - $$ text "that has been suppressed by NoFieldSelectors" + | null gres = [] + | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] where gres = filter isNoFieldSelectorGRE $ lookupGRE_RdrName' tried_rdr_name global_env parents = [ parent | ParentIs parent <- map gre_par gres ] - -- parents may be empty if this is a pattern synonym field without a selector - whose | null parents = empty - | otherwise = text "belonging to the type" <> plural parents - <+> pprQuotedList parents - similarNameSuggestions :: LookingFor -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv - -> RdrName -> SDoc + -> RdrName -> [SimilarName] similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env local_env tried_rdr_name - = case suggest of - [] -> Outputable.empty - [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> text "one of these:" - , nest 2 (pprWithCommas pp_item ps) ] + = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities where - all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities :: [(String, SimilarName)] all_possibilities = case what_look of WL_None -> [] - _ -> [ (showPpr dflags r, (r, Left loc)) + _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc)) | (r,loc) <- local_possibilities local_env ] ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] - suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = text "Perhaps you meant" - - pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined - where loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (text "imported from" <+> ppr (is_mod is)) - - pp_ns :: RdrName -> SDoc - pp_ns rdr | ns /= tried_ns = pprNameSpace ns - | otherwise = Outputable.empty - where ns = rdrNameSpace rdr - tried_occ = rdrNameOcc tried_rdr_name tried_is_sym = isSymOcc tried_occ tried_ns = occNameSpace tried_occ @@ -228,9 +210,9 @@ , let occ = nameOccName name , correct_name_space occ] - global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)] global_possibilities global_env - | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how) | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre @@ -238,14 +220,14 @@ , (mod, how) <- qualsInScope gre , let rdr_qual = mkRdrQual mod occ ] - | otherwise = [ (rdr_unqual, pair) + | otherwise = [ (rdr_unqual, sim) | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ , correct_name_space occ - , pair <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ (rdr_unqual, how) ] + , sim <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ SimilarRdrName rdr_unqual how ] ([], pr:_) -> [ pr ] -- See Note [Only-quals] ([], []) -> [] ] @@ -262,98 +244,43 @@ -------------------- unquals_in_scope :: GlobalRdrElt -> [HowInScope] unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (greDefinitionSrcSpan gre) ] - | otherwise = [ Right ispec + | lcl = [ LocallyBoundAt (greDefinitionSrcSpan gre) ] + | otherwise = [ ImportedBy ispec | i <- bagToList is, let ispec = is_decl i , not (is_qual ispec) ] -------------------- - quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] + quals_only :: GlobalRdrElt -> [SimilarName] -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) + = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec)) | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. + +-- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor -> GlobalRdrEnv -> HomePackageTable -> Module - -> ImportAvails -> RdrName -> SDoc + -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion]) importSuggestions looking_for global_env hpt currMod imports rdr_name - | WL_LocalOnly <- lf_where looking_for = Outputable.empty - | WL_LocalTop <- lf_where looking_for = Outputable.empty - | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty + | WL_LocalOnly <- lf_where looking_for = ([], []) + | WL_LocalTop <- lf_where looking_for = ([], []) + | not (isQual rdr_name || isUnqual rdr_name) = ([], []) | null interesting_imports , Just name <- mod_name , show_not_imported_line name - = hsep - [ text "No module named" - , quotes (ppr name) - , text "is imported." - ] - | is_qualified - , null helpful_imports - , [(mod,_)] <- interesting_imports - = hsep - [ text "Module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot - ] + = ([MissingModule name], []) | is_qualified , null helpful_imports - , not (null interesting_imports) - , mods <- map fst interesting_imports - = hsep - [ text "Neither" - , quotedListWithNor (map ppr mods) - , text "exports" - , quotes (ppr occ_name) <> dot - ] - | [(mod,imv)] <- helpful_imports_non_hiding - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to the import list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_non_hiding) - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to one of these import lists:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_non_hiding - ]) - | [(mod,imv)] <- helpful_imports_hiding - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the explicit hiding list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_hiding) - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the hiding clauses" - , text "in one of these imports:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_hiding - ]) + , (mod : mods) <- map fst interesting_imports + = ([ModulesDoNotExport (mod :| mods) occ_name], []) + | mod : mods <- helpful_imports_non_hiding + = ([], [CouldImportFrom (mod :| mods) occ_name]) + | mod : mods <- helpful_imports_hiding + = ([], [CouldUnhideFrom (mod :| mods) occ_name]) | otherwise - = Outputable.empty + = ([], []) where is_qualified = isQual rdr_name (mod_name, occ_name) = case rdr_name of @@ -409,20 +336,21 @@ , (mod, _) <- qualsInScope gre ] -extensionSuggestions :: RdrName -> SDoc +extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName | rdrName == mkUnqual varName (fsLit "mdo") || rdrName == mkUnqual varName (fsLit "rec") - = text "Perhaps you meant to use RecursiveDo" - | otherwise = Outputable.empty + = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo] + | otherwise + = [] qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } | lcl = case greDefinitionModule gre of Nothing -> [] - Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] - | otherwise = [ (is_as ispec, Right ispec) + Just m -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))] + | otherwise = [ (is_as ispec, ImportedBy ispec) | i <- bagToList is, let ispec = is_decl i ] isGreOk :: LookingFor -> GlobalRdrElt -> Bool @@ -510,10 +438,3 @@ and we have to check the current module in the last added entry of the HomePackageTable. (See test T15611b) -} - -exactNameErr :: Name -> SDoc -exactNameErr name = - hang (text "The exact Name" <+> quotes (ppr name) <+> text "is not in scope") - 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " - , text "perhaps via newName, but did not bind it" - , text "If that's it, then -ddump-splices might be useful" ]) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -18,7 +18,7 @@ warnForallIdentifier, checkUnusedRecordWildcard, mkFieldEnv, - unknownSubordinateErr, badQualBndrErr, typeAppErr, + badQualBndrErr, typeAppErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit, HsDocContext(..), pprHsDocContext, @@ -93,15 +93,14 @@ newLocalBndrsRn = mapM newLocalBndrRn bindLocalNames :: [Name] -> RnM a -> RnM a -bindLocalNames names enclosed_scope - = do { lcl_env <- getLclEnv - ; let th_level = thLevel (tcl_th_ctxt lcl_env) - th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) - [ (n, (NotTopLevel, th_level)) | n <- names ] - rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names - ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' - , tcl_rdr = rdr_env' }) - enclosed_scope } +bindLocalNames names + = updLclEnv $ \ lcl_env -> + let th_level = thLevel (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + in lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' } bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope @@ -593,12 +592,6 @@ (flds, non_flds) = NE.partition isRecFldGRE gres num_flds = length flds num_non_flds = length non_flds - - -unknownSubordinateErr :: SDoc -> RdrName -> SDoc -unknownSubordinateErr doc op -- Doc is "method of class" or - -- "field of constructor" - = quotes (ppr op) <+> text "is not a (visible)" <+> doc dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -573,7 +573,7 @@ (ids, offsets, occs') = syncOccs mbPointers occs - free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids) + free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids) -- It might be that getIdValFromApStack fails, because the AP_STACK -- has been accidentally evaluated, or something else has gone wrong. @@ -623,10 +623,11 @@ newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst -- Similarly, clone the type variables mentioned in the types -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs - = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv))) - | (tv, uniq) <- tvs `zip` uniqsFromSupply us - , let name = setNameUnique (tyVarName tv) uniq ] + newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us) + new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv + where + new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq) + (substTy subst (tyVarKind tv)) isPointer id | [rep] <- typePrimRep (idType id) , isGcPtrRep rep = True @@ -669,8 +670,8 @@ Just new_ty -> do case improveRTTIType hsc_env old_ty new_ty of Nothing -> return $ - warnPprTrace True (text (":print failed to calculate the " - ++ "improvement for a type")) hsc_env + warnPprTrace True (":print failed to calculate the " + ++ "improvement for a type") empty hsc_env Just subst -> do let logger = hsc_logger hsc_env putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" @@ -1059,7 +1060,7 @@ getDictionaryBindings theta = do dictName <- newName (mkDictOcc (mkVarOcc "magic")) let dict_var = mkVanillaGlobal dictName theta - loc <- getCtLocM (GivenOrigin UnkSkol) Nothing + loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing -- Generate a wanted here because at the end of constraint -- solving, most derived constraints get thrown away, which in certain diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -807,17 +807,19 @@ go max_depth my_ty old_ty ind -- We also follow references MutVarClosure{var=contents} - | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty + | Just (tycon,[lev,world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive -- It does not have a constructor at all, -- so we simulate the following one -- MutVar# :: contents_ty -> MutVar# s contents_ty - traceTR (text "Following a MutVar") - contents_tv <- newVar liftedTypeKind + massert (tycon == mutVarPrimTyCon) massert (isUnliftedType my_ty) + traceTR (text "Following a MutVar") + let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + contents_tv <- newVar contents_kind (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany - contents_ty (mkTyConApp tycon [world,contents_ty]) + contents_ty (mkTyConApp tycon [lev, world,contents_ty]) addConstraint (mkVisFunTyMany contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents return (RefWrap my_ty x) @@ -1039,11 +1041,14 @@ case clos of BlackholeClosure{indirectee=ind} -> go my_ty ind IndClosure{indirectee=ind} -> go my_ty ind - MutVarClosure{var=contents} -> do - tv' <- newVar liftedTypeKind - world <- newVar liftedTypeKind - addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv']) - return [(tv', contents)] + MutVarClosure{var=contents} + | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty + -> do + massert (_tycon == mutVarPrimTyCon) + tv' <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev]) + world <- newVar liftedTypeKind + addConstraint my_ty $ mkMutVarPrimTy world tv' + return [(tv', contents)] APClosure {payload=pLoad} -> do -- #19559 (incr) mapM_ (go my_ty) pLoad return [] diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs --- a/compiler/GHC/Stg/Subst.hs +++ b/compiler/GHC/Stg/Subst.hs @@ -54,7 +54,7 @@ | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id' | Just id' <- lookupInScope in_scope id = id' - | otherwise = warnPprTrace True (text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) id + | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -42,6 +42,7 @@ import GHC.Core import GHC.Types.Literal import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Core.Type import GHC.Types.RepType import GHC.Core.DataCon @@ -54,7 +55,6 @@ import GHC.Utils.Error import GHC.Types.Unique import GHC.Builtin.Uniques -import GHC.Builtin.Utils ( primOpId ) import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Panic.Plain diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -16,7 +16,6 @@ import GHC.Prelude as Prelude import GHC.Driver.Backend -import GHC.Driver.Session import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad @@ -26,6 +25,7 @@ import GHC.StgToCmm.Layout import GHC.StgToCmm.Utils import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Hpc import GHC.StgToCmm.Ticky import GHC.StgToCmm.Types (ModuleLFInfos) @@ -73,8 +73,7 @@ codeGen :: Logger -> TmpFs - -> DynFlags - -> Module + -> StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. @@ -83,7 +82,7 @@ -> Stream IO CmmGroup ModuleLFInfos -- Output as a stream, so codegen can -- be interleaved with output -codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons +codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -94,7 +93,8 @@ cg fcode = do (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref - let (a,st') = runC dflags this_mod st (getCmm fcode) + let fstate = initFCodeState $ stgToCmmPlatform cfg + let (a,st') = runC cfg fstate st (getCmm fcode) -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! @@ -108,9 +108,9 @@ -- FIRST. This is because when -split-objs is on we need to -- combine this block with its initialisation routines; see -- Note [pipeline-split-init]. - ; cg (mkModuleInit cost_centre_info this_mod hpc_info) + ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info) - ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds + ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in @@ -127,7 +127,7 @@ -- Emit special info tables for everything used in this module -- This will only do something if `-fdistinct-info-tables` is turned on. - ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv) + ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv) ; final_state <- liftIO (readIORef cgref) ; let cg_id_infos = cgs_binds final_state @@ -140,7 +140,7 @@ !lf = cg_lf info !generatedInfo - | gopt Opt_OmitInterfacePragmas dflags + | stgToCmmOmitIfPragmas cfg = emptyNameEnv | otherwise = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) @@ -162,17 +162,17 @@ style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode () -cgTopBinding logger tmpfs dflags = \case +cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode () +cgTopBinding logger tmpfs cfg = \case StgTopLifted (StgNonRec id rhs) -> do - let (info, fcode) = cgTopRhs dflags NonRecursive id rhs + let (info, fcode) = cgTopRhs cfg NonRecursive id rhs fcode addBindC info StgTopLifted (StgRec pairs) -> do let (bndrs, rhss) = unzip pairs let pairs' = zip bndrs rhss - r = unzipWith (cgTopRhs dflags Recursive) pairs' + r = unzipWith (cgTopRhs cfg Recursive) pairs' (infos, fcodes) = unzip r addBindsC infos sequence_ fcodes @@ -182,31 +182,32 @@ -- emit either a CmmString literal or dump the string in a file and emit a -- CmmFileEmbed literal. -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr - let isNCG = backend dflags == NCG - isSmall = fromIntegral (BS.length str) <= binBlobThreshold dflags - asString = binBlobThreshold dflags == 0 || isSmall + let bin_blob_threshold = stgToCmmBinBlobThresh cfg + isNCG = platformDefaultBackend (stgToCmmPlatform cfg) == NCG + isSmall = fromIntegral (BS.length str) <= bin_blob_threshold + asString = bin_blob_threshold == 0 || isSmall (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule ".dat" + bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl - addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) + addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit) -cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) +cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args) - = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args) +cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args) + = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) +cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body) = assert (isEmptyDVarSet fvs) -- There should be no free variables - cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body + cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body --------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -26,6 +26,7 @@ import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad import GHC.StgToCmm.Env @@ -106,10 +107,9 @@ gen_code lf_info _closure_label = do { profile <- getProfile - ; dflags <- getDynFlags ; let name = idName id ; mod_name <- getModuleName - ; let descr = closureDescription dflags mod_name name + ; let descr = closureDescription mod_name name closure_info = mkClosureInfo profile True id lf_info 0 0 descr -- We don't generate the static closure here, because we might @@ -356,9 +356,8 @@ -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName - ; dflags <- getDynFlags ; let name = idName bndr - descr = closureDescription dflags mod_name name + descr = closureDescription mod_name name fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details) @@ -404,15 +403,15 @@ do { -- LAY OUT THE OBJECT mod_name <- getModuleName - ; dflags <- getDynFlags - ; profile <- getProfile - ; let platform = profilePlatform profile + ; cfg <- getStgToCmmConfig + ; let profile = stgToCmmProfile cfg + ; let platform = stgToCmmPlatform cfg header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, payload_w_offsets) = mkVirtHeapOffsets profile header (addArgReps (nonVoidStgArgs payload)) - descr = closureDescription dflags mod_name (idName bndr) + descr = closureDescription mod_name (idName bndr) closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -563,16 +562,18 @@ -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do profile <- getProfile - platform <- getPlatform + = do cfg <- getStgToCmmConfig + upd_frame <- getUpdFrameOff let node = idToReg platform (NonVoid bndr) + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg slow_lbl = closureSlowEntryLabel platform cl_info fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkJump profile NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) - (initUpdFrameOff platform) + upd_frame tscope <- getTickScope emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) (jump, tscope) @@ -620,9 +621,10 @@ emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do - dflags <- getDynFlags - profile <- getProfile - let platform = profilePlatform profile + cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + is_eager_bh = stgToCmmEagerBlackHole cfg -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer @@ -642,8 +644,7 @@ -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (profileIsProfiling profile) - && gopt Opt_EagerBlackHoling dflags + let eager_blackholing = not (profileIsProfiling profile) && is_eager_bh -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't -- work with profiling. @@ -668,11 +669,11 @@ then do tickyUpdateFrameOmitted; body else do tickyPushUpdateFrame - dflags <- getDynFlags + cfg <- getStgToCmmConfig let - bh = blackHoleOnEntry closure_info && - not (sccProfilingEnabled dflags) && - gopt Opt_EagerBlackHoling dflags + bh = blackHoleOnEntry closure_info + && not (stgToCmmSCCProfiling cfg) + && stgToCmmEagerBlackHole cfg lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel @@ -730,11 +731,12 @@ -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do - { profile <- getProfile + { cfg <- getStgToCmmConfig -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction + ; let profile = stgToCmmProfile cfg ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl @@ -744,8 +746,9 @@ -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; ptr_opts <- getPtrOpts - ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node))) + ; let align_check = stgToCmmAlignCheck cfg + ; let target = entryCode platform + (closureInfoPtr platform align_check (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF @@ -762,17 +765,11 @@ -- @closureDescription@ from the let binding information. closureDescription - :: DynFlags - -> Module -- Module + :: Module -- Module -> Name -- Id of closure binding -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor -closureDescription dflags mod_name name - = let ctx = initSDocContext dflags defaultDumpStyle - -- defaultDumpStyle, because we want to see the unique on the Name. - in renderWithContext ctx (char '<' <> - (if isExternalName name - then ppr name -- ppr will include the module name prefix - else pprModule mod_name <> char '.' <> ppr name) <> - char '>') +closureDescription mod_name name + = renderWithContext defaultSDocContext + (char '<' <> pprFullName mod_name name <> char '>') diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -35,9 +35,9 @@ isLFThunk, isLFReEntrant, lfUpdatable, -- * Used by other modules - CgLoc(..), SelfLoopInfo, CallMethod(..), + CgLoc(..), CallMethod(..), nodeMustPointToIt, isKnownFun, funTag, tagForArity, - CallOpts(..), getCallMethod, + getCallMethod, -- * ClosureInfo ClosureInfo, @@ -78,6 +78,7 @@ import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types +import GHC.StgToCmm.Sequel import GHC.Types.CostCentre import GHC.Cmm.BlockId @@ -99,6 +100,7 @@ import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 +import GHC.StgToCmm.Config ----------------------------------------------------------------------------- -- Data types and synonyms @@ -126,8 +128,6 @@ CmmLoc e -> text "cmm" <+> pdoc platform e LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs -type SelfLoopInfo = (Id, BlockId, [LocalReg]) - -- used by ticky profiling isKnownFun :: LambdaFormInfo -> Bool isKnownFun LFReEntrant{} = True @@ -492,13 +492,7 @@ CLabel -- The code label RepArity -- Its arity -data CallOpts = CallOpts - { co_profile :: !Profile -- ^ Platform profile - , co_loopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) - , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) - } - -getCallMethod :: CallOpts +getCallMethod :: StgToCmmConfig -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling @@ -511,12 +505,11 @@ -- tail calls using the same data constructor, -- JumpToIt. This saves us one case branch in -- cgIdApp - -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? + -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call -> CallMethod -getCallMethod opts _ id _ n_args v_args _cg_loc - (Just (self_loop_id, block_id, args)) - | co_loopification opts +getCallMethod cfg _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) + | stgToCmmLoopification cfg , id == self_loop_id , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that: @@ -527,14 +520,13 @@ -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc - _self_loop_info +getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (profileIsProfiling (co_profile opts)) + && not (profileIsProfiling (stgToCmmProfile cfg)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = assert (arity /= 0) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt @@ -544,14 +536,14 @@ -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything -getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) +getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || co_ticky opts -- to catch double entry + | updatable || stgToCmmDoTicky cfg -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -573,7 +565,7 @@ | otherwise -- Jump direct to code for single-entry thunks = assert (n_args == 0) $ - DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info + DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info @@ -583,8 +575,7 @@ = assertPpr (n_args == 0) (ppr name <+> ppr n_args) EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) - _self_loop_info +getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method" diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -18,7 +18,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Platform.Profile import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -38,7 +37,6 @@ import GHC.Types.CostCentre import GHC.Unit import GHC.Core.DataCon -import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info( CafInfo( NoCafRefs ) ) @@ -53,19 +51,20 @@ import Control.Monad import Data.Char +import GHC.StgToCmm.Config (stgToCmmPlatform) --------------------------------------------------------------- -- Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: DynFlags +cgTopRhsCon :: StgToCmmConfig -> Id -- Name of thing bound to this RHS -> DataCon -- Id -> ConstructorNumber -> [NonVoid StgArg] -- Args -> (CgIdInfo, FCode ()) -cgTopRhsCon dflags id con mn args - | Just static_info <- precomputedStaticConInfo_maybe dflags id con args +cgTopRhsCon cfg id con mn args + | Just static_info <- precomputedStaticConInfo_maybe cfg id con args , let static_code | isInternalName name = pure () | otherwise = gen_code = -- There is a pre-allocated static closure available; use it @@ -81,7 +80,7 @@ = (id_Info, gen_code) where - platform = targetPlatform dflags + platform = stgToCmmPlatform cfg id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args @@ -92,7 +91,7 @@ ; this_mod <- getModuleName ; when (platformOS platform == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. - massert (not (isDllConApp dflags this_mod con (map fromNonVoid args))) + massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))) ; assert (args `lengthIs` countConRepArgs con ) return () -- LAY IT OUT @@ -166,18 +165,20 @@ -> FCode (CgIdInfo, FCode CmmAGraph) -- Return details about how to find it and initialization code buildDynCon binder mn actually_bound cc con args - = do dflags <- getDynFlags - buildDynCon' dflags binder mn actually_bound cc con args + = do cfg <- getStgToCmmConfig + -- pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True + case precomputedStaticConInfo_maybe cfg binder con args of + Just cgInfo -> return (cgInfo, return mkNop) + Nothing -> buildDynCon' binder mn actually_bound cc con args -buildDynCon' :: DynFlags - -> Id -> ConstructorNumber +buildDynCon' :: Id + -> ConstructorNumber -> Bool -> CostCentreStack -> DataCon -> [NonVoid StgArg] -> FCode (CgIdInfo, FCode CmmAGraph) - {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static constructor; but I concluded that it just isn't worth it. @@ -188,14 +189,8 @@ the addr modes of the args is that we may be in a "knot", and premature looking at the args will cause the compiler to black-hole! -} - -buildDynCon' dflags binder _ _ _cc con args - | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args - -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True - = return (cgInfo, return mkNop) - -------- buildDynCon': the general case ----------- -buildDynCon' _ binder mn actually_bound ccs con args +buildDynCon' binder mn actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -204,8 +199,9 @@ gen_code reg = do { modu <- getModuleName - ; profile <- getProfile - ; let platform = profilePlatform profile + ; cfg <- getStgToCmmConfig + ; let platform = stgToCmmPlatform cfg + profile = stgToCmmProfile cfg (tot_wds, ptr_wds, args_w_offsets) = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds @@ -224,6 +220,7 @@ blame_cc = use_cc -- cost-centre on which to blame the alloc (same) + {- Note [Precomputed static closures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -317,36 +314,36 @@ because they don't support cross package data references well. -} --- (precomputedStaticConInfo_maybe dflags id con args) +-- (precomputedStaticConInfo_maybe cfg id con args) -- returns (Just cg_id_info) -- if there is a precomputed static closure for (con args). -- In that case, cg_id_info addresses it. -- See Note [Precomputed static closures] -precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo -precomputedStaticConInfo_maybe dflags binder con [] +precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo +precomputedStaticConInfo_maybe cfg binder con [] -- Nullary constructors | isNullaryRepDataCon con - = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con) + = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) -precomputedStaticConInfo_maybe dflags binder con [arg] +precomputedStaticConInfo_maybe cfg binder con [arg] -- Int/Char values with existing closures in the RTS | intClosure || charClosure - , platformOS platform /= OSMinGW32 || not (positionIndependent dflags) + , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg) , Just val <- getClosurePayload arg , inRange val = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) val_int = fromIntegral val :: Int - offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1) + offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload static_amode = cmmLabelOffW platform intlike_lbl offsetW in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode where - profile = targetProfile dflags - platform = profilePlatform profile - intClosure = maybeIntLikeCon con + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val - getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just $ (fromIntegral . ord $ val) + getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val) getClosurePayload _ = Nothing -- Avoid over/underflow by comparisons at type Integer! inRange :: Integer -> Bool diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -44,9 +44,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Driver.Session - ------------------------------------- -- Manipulating CgIdInfo ------------------------------------- @@ -84,16 +82,16 @@ idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e +idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc -- | A tag adds a byte offset to the pointer addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr -addDynTag platform expr tag = cmmOffsetB platform expr tag +addDynTag = cmmOffsetB maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) -maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) +maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args) maybeLetNoEscape _other = Nothing @@ -120,7 +118,7 @@ getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { platform <- targetPlatform <$> getDynFlags + = do { platform <- getPlatform ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -179,7 +177,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] -bindArgsToRegs args = mapM bindArgToReg args +bindArgsToRegs = mapM bindArgToReg idToReg :: Platform -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -91,9 +91,10 @@ slow_path <- getCode $ do tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig emitAssign (CmmLocal result_reg) - $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp))) + $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) fast_path <- getCode $ do -- Return the constructor index from the pointer tag @@ -102,9 +103,10 @@ $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) -- Return the constructor index recorded in the info table return_info_tag <- getCode $ do - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig emitAssign (CmmLocal result_reg) - $ getConstrTag ptr_opts (cmmUntag platform amode) + $ getConstrTag profile align_check (cmmUntag platform amode) emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) @@ -540,9 +542,9 @@ isSimpleOp (StgPrimOp DataToTagOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args - dflags <- getDynFlags + cfg <- getStgToCmmConfig -- See Note [Inlining out-of-line primops and heap checks] - return $! shouldInlinePrimOp dflags op arg_exprs + return $! shouldInlinePrimOp cfg op arg_exprs isSimpleOp (StgPrimCallOp _) _ = return False ----------------- @@ -615,9 +617,10 @@ else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] do - ptr_opts <- getPtrOpts + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg) - !itag_expr = getConstrTag ptr_opts untagged_ptr + !itag_expr = getConstrTag profile align_check untagged_ptr !info0 = first pred <$> via_info if null via_ptr then emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) @@ -888,16 +891,16 @@ cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do fun_info <- getCgIdInfo fun_id - self_loop_info <- getSelfLoop - call_opts <- getCallOpts - profile <- getProfile - let fun_arg = StgVarArg fun_id - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cg_lf fun_info - n_args = length args - v_args = length $ filter (isZeroBitTy . stgArgType) args - case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of + cfg <- getStgToCmmConfig + self_loop <- getSelfLoop + let profile = stgToCmmProfile cfg + fun_arg = StgVarArg fun_id + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + n_args = length args + v_args = length $ filter (isZeroBitTy . stgArgType) args + case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn [] @@ -975,7 +978,7 @@ -- Implementation is spread across a couple of places in the code: -- -- * FCode monad stores additional information in its reader environment --- (cgd_self_loop field). This information tells us which function can +-- (stgToCmmSelfLoop field). This information tells us which function can -- tail call itself in an optimized way (it is the function currently -- being compiled), what is the label of a loop header (L1 in example above) -- and information about local registers in which we should arguments @@ -1008,7 +1011,7 @@ -- command-line option. -- -- * Command line option to turn loopification on and off is implemented in --- DynFlags. +-- DynFlags, then passed to StgToCmmConfig for this phase. -- -- -- Note [Void arguments in self-recursive tail calls] @@ -1036,12 +1039,12 @@ emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do - { ptr_opts <- getPtrOpts - ; platform <- getPlatform - ; profile <- getProfile + { platform <- getPlatform + ; profile <- getProfile ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of -- For a return, we have the option of generating a tag-test or -- not. If the value is tagged, we can return directly, which @@ -1052,7 +1055,9 @@ -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg + { let entry = entryCode platform + $ closureInfoPtr platform align_check + $ CmmReg nodeReg ; emit $ mkJump profile NativeNodeCall entry [cmmUntag platform fun] updfr_off ; return AssignedDirectly @@ -1084,17 +1089,18 @@ -- code in the enclosing case expression. -- AssignTo res_regs _ -> do - { lret <- newBlockId - ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] + { lret <- newBlockId ; lcall <- newBlockId - ; updfr_off <- getUpdFrameOff + ; updfr_off <- getUpdFrameOff + ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] ; let area = Young lret ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -34,7 +34,7 @@ getCode, getCodeR, getCodeScoped, emitOutOfLine, withUpdFrameOff, getUpdFrameOff, - getProfile, getPlatform, getPtrOpts + getProfile, getPlatform, getContext ) where @@ -50,10 +50,8 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph -import GHC.Cmm.Info import GHC.Cmm.BlockId -import GHC.Driver.Session import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Unique.FM @@ -61,6 +59,7 @@ import GHC.Types.Unique.Supply import Control.Monad (ap) +import GHC.Utils.Outputable (SDocContext) -- | The environment contains variable definitions or blockids. data Named @@ -103,17 +102,14 @@ u <- getUniqueM return (decls, u) -instance HasDynFlags CmmParse where - getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) - getProfile :: CmmParse Profile getProfile = EC (\_ _ d -> (d,) <$> F.getProfile) getPlatform :: CmmParse Platform getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) -getPtrOpts :: CmmParse PtrOpts -getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts) +getContext :: CmmParse SDocContext +getContext = EC (\_ _ d -> (d,) <$> F.getContext) -- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation. @@ -127,7 +123,6 @@ (_, a) <- F.fixC $ \ ~(decls, _) -> fcode c (addListToUFM e decls) globalDecls return (globalDecls, a) - -- | Get the current environment from the monad. getEnv :: CmmParse Env diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -603,9 +603,9 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- For certain types passed to foreign calls, we adjust the actual --- value passed to the call. For ByteArray#, Array#, SmallArray#, --- and ArrayArray#, we pass the address of the array's payload, not --- the address of the heap object. For example, consider +-- value passed to the call. For ByteArray#, Array# and SmallArray#, +-- we pass the address of the array's payload, not the address of +-- the heap object. For example, consider: -- foreign import "c_foo" foo :: ByteArray# -> Int# -> IO () -- At a Haskell call like `foo x y`, we'll generate a C call that -- is more like @@ -715,8 +715,6 @@ typeToStgFArgType typ | tycon == arrayPrimTyCon = StgArrayType | tycon == mutableArrayPrimTyCon = StgArrayType - | tycon == arrayArrayPrimTyCon = StgArrayType - | tycon == mutableArrayArrayPrimTyCon = StgArrayType | tycon == smallArrayPrimTyCon = StgSmallArrayType | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType | tycon == byteArrayPrimTyCon = StgByteArrayType diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -429,7 +429,7 @@ -- is more efficient), but cannot be optimized away in the non-allocating -- case because it may occur in a loop noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a -noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code +noEscapeHeapCheck = altOrNoEscapeHeapCheck True cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a @@ -605,9 +605,9 @@ -> CmmAGraph -- What to do on failure -> FCode () do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do - dflags <- getDynFlags - platform <- getPlatform - gc_id <- newBlockId + omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig + platform <- getPlatform + gc_id <- newBlockId let Just alloc_lit = mb_alloc_lit @@ -644,13 +644,13 @@ | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () - if (isJust mb_alloc_lit) + if isJust mb_alloc_lit then do tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) else - when (checkYield && not (gopt Opt_OmitYields dflags)) $ do + when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) [CmmReg hpLimReg, diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -11,8 +11,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session - import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils @@ -39,13 +37,13 @@ -- | Emit top-level tables for HPC and return code to initialise initHpc :: Module -> HpcInfo -> FCode () -initHpc _ (NoHpcInfo {}) +initHpc _ NoHpcInfo{} = return () initHpc this_mod (HpcInfo tickCount _hashNo) - = do dflags <- getDynFlags - when (gopt Opt_Hpc dflags) $ + = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig + when do_hpc $ emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) + [ CmmInt 0 W64 | _ <- take tickCount [0 :: Int ..] ] diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -33,9 +33,6 @@ import GHC.Prelude hiding ((<*>)) -import GHC.Driver.Session -import GHC.Driver.Ppr - import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern ) @@ -67,6 +64,8 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad +import GHC.StgToCmm.Config (stgToCmmPlatform) +import GHC.StgToCmm.Types ------------------------------------------------------------------------ -- Call and return sequences @@ -196,9 +195,12 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args - = do dflags <- getDynFlags - profile <- getProfile - let platform = profilePlatform profile + = do cfg <- getStgToCmmConfig + let profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg + ctx = stgToCmmContext cfg + fast_pap = stgToCmmFastPAPCalls cfg + align_sat = stgToCmmAlignCheck cfg argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -206,18 +208,17 @@ r <- direct_call "slow_call" NativeNodeCall (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) emitComment $ mkFastString ("slow_call for " ++ - showSDoc dflags (pdoc platform fun) ++ + renderWithContext ctx (pdoc platform fun) ++ " with pat " ++ unpackFS rts_fun) return r -- Note [avoid intermediate PAPs] let n_args = length stg_args - if n_args > arity && gopt Opt_FastPAPCalls dflags + if n_args > arity && fast_pap then do - ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun fun_iptr <- (CmmReg . CmmLocal) `fmap` - assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv)) + assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv)) -- ToDo: we could do slightly better here by reusing the -- continuation from the slow call, which we have in r. @@ -303,15 +304,14 @@ = emitCall (call_conv, NativeReturn) target (nonVArgs args) | otherwise -- Note [over-saturated calls] - = do dflags <- getDynFlags + = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (nonVArgs (stack_args dflags)) + (nonVArgs (slowArgs rest_args do_scc_prof)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args - stack_args dflags = slowArgs dflags rest_args real_arity = case call_conv of NativeNodeCall -> arity+1 _ -> arity @@ -375,12 +375,11 @@ -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)] -slowArgs _ [] = [] -slowArgs dflags args -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled dflags - = save_cccs ++ this_pat ++ slowArgs dflags rest_args - | otherwise = this_pat ++ slowArgs dflags rest_args +slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs [] _ = mempty +slowArgs args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled + | otherwise = this_pat ++ slowArgs rest_args sccProfilingEnabled where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -14,7 +14,7 @@ module GHC.StgToCmm.Monad ( FCode, -- type - initC, runC, fixC, + initC, initFCodeState, runC, fixC, newUnique, emitLabel, @@ -28,7 +28,7 @@ getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage, - getCallOpts, getPtrOpts, + getContext, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', @@ -45,7 +45,7 @@ setTickyCtrLabel, getTickyCtrLabel, tickScope, getTickScope, - withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + withUpdFrameOff, getUpdFrameOff, HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, @@ -54,13 +54,13 @@ getModuleName, -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, + getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig, -- more localised access to monad state CgIdInfo(..), getBinds, setBinds, -- out of general friendliness, we also export ... - CgInfoDownwards(..), CgState(..) -- non-abstract + StgToCmmConfig(..), CgState(..) -- non-abstract ) where import GHC.Prelude hiding( sequence, succ ) @@ -68,13 +68,13 @@ import GHC.Platform import GHC.Platform.Profile import GHC.Cmm +import GHC.StgToCmm.Config import GHC.StgToCmm.Closure -import GHC.Driver.Session +import GHC.StgToCmm.Sequel import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id @@ -109,24 +109,30 @@ -- - the current heap usage -- - a UniqSupply -- --- - A reader monad, for CgInfoDownwards, containing --- - DynFlags, +-- - A reader monad, for StgToCmmConfig, containing +-- - the profile, -- - the current Module +-- - the debug level +-- - a bunch of flags see StgToCmm.Config for full details + +-- - A second reader monad with: -- - the update-frame offset -- - the ticky counter label -- - the Sequel (the continuation to return to) -- - the self-recursive tail call information +-- - The tick scope for new blocks and ticks +-- -------------------------------------------------------- -newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } +newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) } -- Not derived because of #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor FCode where fmap f (FCode m) = - FCode $ \info_down state -> - case m info_down state of + FCode $ \cfg fst state -> + case m cfg fst state of (x, state') -> (f x, state') -- This pattern synonym makes the simplifier monad eta-expand, @@ -134,29 +140,31 @@ -- See #18202. -- See Note [The one-shot state monad trick] in GHC.Utils.Monad {-# COMPLETE FCode #-} -pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) +pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)) -> FCode a pattern FCode m <- FCode' m where - FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) + FCode m = FCode' $ oneShot (\cfg -> oneShot + (\fstate -> oneShot + (\state -> m cfg fstate state))) instance Applicative FCode where - pure val = FCode (\_info_down state -> (val, state)) + pure val = FCode (\_cfg _fstate state -> (val, state)) {-# INLINE pure #-} (<*>) = ap instance Monad FCode where FCode m >>= k = FCode $ - \info_down state -> - case m info_down state of + \cfg fstate state -> + case m cfg fstate state of (m_result, new_state) -> case k m_result of - FCode kcode -> kcode info_down new_state + FCode kcode -> kcode cfg fstate new_state {-# INLINE (>>=) #-} instance MonadUnique FCode where getUniqueSupplyM = cgs_uniqs <$> getState - getUniqueM = FCode $ \_ st -> + getUniqueM = FCode $ \_ _ st -> let (u, us') = takeUniqFromSupply (cgs_uniqs st) in (u, st { cgs_uniqs = us' }) @@ -164,36 +172,18 @@ initC = do { uniqs <- mkSplitUniqSupply 'c' ; return (initCgState uniqs) } -runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) -runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st +runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState) +runC cfg fst st fcode = doFCode fcode cfg fst st fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode $ - \info_down state -> let (v, s) = doFCode (fcode v) info_down state - in (v, s) + \cfg fstate state -> + let (v, s) = doFCode (fcode v) cfg fstate state + in (v, s) -------------------------------------------------------- -- The code generator environment -------------------------------------------------------- - --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified --- as we go along. - -data CgInfoDownwards -- information only passed *downwards* by the monad - = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel, -- What to do at end of basic block - cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled - -- as local jumps? See Note - -- [Self-recursive tail calls] in - -- GHC.StgToCmm.Expr - cgd_tick_scope:: CmmTickScope -- Tick scope for new blocks & ticks - } - type CgBindings = IdEnv CgIdInfo data CgIdInfo @@ -207,24 +197,6 @@ pdoc env (CgIdInfo { cg_id = id, cg_loc = loc }) = ppr id <+> text "-->" <+> pdoc env loc --- Sequel tells what to do with the result of this expression -data Sequel - = Return -- Return result(s) to continuation found on the stack. - - | AssignTo - [LocalReg] -- Put result(s) in these regs and fall through - -- NB: no void arguments here - -- - Bool -- Should we adjust the heap pointer back to - -- recover space that's unused on this path? - -- We need to do this only if the expression - -- may allocate (e.g. it's a foreign call or - -- allocating primOp) - -instance Outputable Sequel where - ppr Return = text "Return" - ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b - -- See Note [sharing continuations] below data ReturnKind = AssignedDirectly @@ -297,24 +269,6 @@ -- fall back to AssignedDirectly. -- - -initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards -initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags - , cgd_mod = mod - , cgd_updfr_off = initUpdFrameOff (targetPlatform dflags) - , cgd_ticky = mkTopTickyCtrLabel - , cgd_sequel = initSequel - , cgd_self_loop = Nothing - , cgd_tick_scope= GlobalScope } - -initSequel :: Sequel -initSequel = Return - -initUpdFrameOff :: Platform -> UpdFrameOffset -initUpdFrameOff platform = platformWordSizeInBytes platform -- space for the RA - - -------------------------------------------------------- -- The code generator state -------------------------------------------------------- @@ -337,6 +291,17 @@ -- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked -- in #19245 +data FCodeState = + MkFCodeState { fcs_upframeoffset :: UpdFrameOffset -- ^ Size of current update frame UpdFrameOffset must be kept lazy or + -- else the RTS will deadlock _and_ also experience a severe + -- performance degredation + , fcs_sequel :: !Sequel -- ^ What to do at end of basic block + , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps? + -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr + , fcs_ticky :: !CLabel -- ^ Destination for ticky counts + , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks + } + data HeapUsage -- See Note [Virtual and real heap pointers] = HeapUsage { virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word @@ -418,14 +383,14 @@ hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } -------------------------------------------------------- --- Operators for getting and setting the state and "info_down". +-- Operators for getting and setting the state and "stgToCmmConfig". -------------------------------------------------------- getState :: FCode CgState -getState = FCode $ \_info_down state -> (state, state) +getState = FCode $ \_cfg _fstate state -> (state, state) setState :: CgState -> FCode () -setState state = FCode $ \_info_down _ -> ((), state) +setState state = FCode $ \_cfg _fstate _ -> ((), state) getHpUsage :: FCode HeapUsage getHpUsage = do @@ -462,9 +427,9 @@ state <- getState setState $ state {cgs_binds = new_binds} -withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> - case fcode info_down newstate of +withCgState :: FCode a -> CgState -> FCode (a,CgState) +withCgState (FCode fcode) newstate = FCode $ \cfg fstate state -> + case fcode cfg fstate newstate of (retval, state2) -> ((retval,state2), state) newUniqSupply :: FCode UniqSupply @@ -486,68 +451,41 @@ ; return (LocalReg uniq rep) } ------------------ -getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (info_down,state) +initFCodeState :: Platform -> FCodeState +initFCodeState p = + MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p + , fcs_sequel = Return + , fcs_selfloop = Nothing + , fcs_ticky = mkTopTickyCtrLabel + , fcs_tickscope = GlobalScope + } +getFCodeState :: FCode FCodeState +getFCodeState = FCode $ \_ fstate state -> (fstate,state) + +-- basically local for the reader monad +withFCodeState :: FCode a -> FCodeState -> FCode a +withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state + getSelfLoop :: FCode (Maybe SelfLoopInfo) -getSelfLoop = do - info_down <- getInfoDown - return $ cgd_self_loop info_down +getSelfLoop = fcs_selfloop <$> getFCodeState withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a withSelfLoop self_loop code = do - info_down <- getInfoDown - withInfoDown code (info_down {cgd_self_loop = Just self_loop}) - -instance HasDynFlags FCode where - getDynFlags = liftM cgd_dflags getInfoDown - -getProfile :: FCode Profile -getProfile = targetProfile <$> getDynFlags - -getPlatform :: FCode Platform -getPlatform = profilePlatform <$> getProfile - -getCallOpts :: FCode CallOpts -getCallOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ CallOpts - { co_profile = profile - , co_loopification = gopt Opt_Loopification dflags - , co_ticky = gopt Opt_Ticky dflags - } - -getPtrOpts :: FCode PtrOpts -getPtrOpts = do - dflags <- getDynFlags - profile <- getProfile - pure $ PtrOpts - { po_profile = profile - , po_align_check = gopt Opt_AlignmentSanitisation dflags - } - - -withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state - --- ---------------------------------------------------------------------------- --- Get the current module name - -getModuleName :: FCode Module -getModuleName = do { info <- getInfoDown; return (cgd_mod info) } + fstate <- getFCodeState + withFCodeState code (fstate {fcs_selfloop = Just self_loop}) -- ---------------------------------------------------------------------------- -- Get/set the end-of-block info withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) } + = do { fstate <- getFCodeState + ; withFCodeState code (fstate { fcs_sequel = sequel + , fcs_selfloop = Nothing }) } getSequel :: FCode Sequel -getSequel = do { info <- getInfoDown - ; return (cgd_sequel info) } +getSequel = fcs_sequel <$> getFCodeState -- ---------------------------------------------------------------------------- -- Get/set the size of the update frame @@ -561,35 +499,29 @@ withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code - = do { info <- getInfoDown - ; withInfoDown code (info {cgd_updfr_off = size }) } + = do { fstate <- getFCodeState + ; withFCodeState code (fstate {fcs_upframeoffset = size }) } getUpdFrameOff :: FCode UpdFrameOffset -getUpdFrameOff - = do { info <- getInfoDown - ; return $ cgd_updfr_off info } +getUpdFrameOff = fcs_upframeoffset <$> getFCodeState -- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel -getTickyCtrLabel = do - info <- getInfoDown - return (cgd_ticky info) +getTickyCtrLabel = fcs_ticky <$> getFCodeState setTickyCtrLabel :: CLabel -> FCode a -> FCode a setTickyCtrLabel ticky code = do - info <- getInfoDown - withInfoDown code (info {cgd_ticky = ticky}) + fstate <- getFCodeState + withFCodeState code (fstate {fcs_ticky = ticky}) -- ---------------------------------------------------------------------------- -- Manage tick scopes -- | The current tick scope. We will assign this to generated blocks. getTickScope :: FCode CmmTickScope -getTickScope = do - info <- getInfoDown - return (cgd_tick_scope info) +getTickScope = fcs_tickscope <$> getFCodeState -- | Places blocks generated by the given code into a fresh -- (sub-)scope. This will make sure that Cmm annotations in our scope @@ -597,13 +529,35 @@ -- way around. tickScope :: FCode a -> FCode a tickScope code = do - info <- getInfoDown - if debugLevel (cgd_dflags info) == 0 then code else do + cfg <- getStgToCmmConfig + fstate <- getFCodeState + if stgToCmmDebugLevel cfg == 0 then code else do u <- newUnique - let scope' = SubScope u (cgd_tick_scope info) - withInfoDown code info{ cgd_tick_scope = scope' } + let scope' = SubScope u (fcs_tickscope fstate) + withFCodeState code fstate{ fcs_tickscope = scope' } +-- ---------------------------------------------------------------------------- +-- Config related helpers +getStgToCmmConfig :: FCode StgToCmmConfig +getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state) + +getProfile :: FCode Profile +getProfile = stgToCmmProfile <$> getStgToCmmConfig + +getPlatform :: FCode Platform +getPlatform = profilePlatform <$> getProfile + +getContext :: FCode SDocContext +getContext = stgToCmmContext <$> getStgToCmmConfig + +-- ---------------------------------------------------------------------------- +-- Get the current module name + +getModuleName :: FCode Module +getModuleName = stgToCmmThisModule <$> getStgToCmmConfig + + -------------------------------------------------------- -- Forking -------------------------------------------------------- @@ -618,14 +572,16 @@ forkClosureBody body_code = do { platform <- getPlatform - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff platform - , cgd_self_loop = Nothing } + ; cfg <- getStgToCmmConfig + ; fstate <- getFCodeState + ; us <- newUniqSupply + ; state <- getState + ; let fcs = fstate { fcs_sequel = Return + , fcs_upframeoffset = platformWordSizeInBytes platform + , fcs_selfloop = Nothing + } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) = doFCode body_code body_info_down fork_state_in + ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } forkLneBody :: FCode a -> FCode a @@ -636,11 +592,12 @@ -- the successor. In particular, any heap usage from the enclosed -- code is discarded; it should deal with its own heap consumption. forkLneBody body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in + (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } @@ -649,12 +606,13 @@ -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply + ; state <- getState + ; fstate <- getFCodeState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state , cgs_hp_usg = cgs_hp_usg state } - ((), fork_state_out) = doFCode body_code info_down fork_state_in + ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } forkAlts :: [FCode a] -> FCode [a] @@ -664,11 +622,12 @@ -- that the virtual Hp is moved on to the worst virtual Hp for the branches forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply + = do { cfg <- getStgToCmmConfig + ; us <- newUniqSupply ; state <- getState + ; fstate <- getFCodeState ; let compile us branch - = (us2, doFCode branch info_down branch_state) + = (us2, doFCode branch cfg fstate branch_state) where (us1,us2) = splitUniqSupply us branch_state = (initCgState us1) { @@ -693,7 +652,7 @@ getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode = do { state1 <- getState - ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) + ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop }) ; setState $ state2 { cgs_stmts = cgs_stmts state1 } ; return (a, cgs_stmts state2) } @@ -706,7 +665,7 @@ = do { state1 <- getState ; ((a, tscope), state2) <- tickScope $ - flip withState state1 { cgs_stmts = mkNop } $ + flip withCgState state1 { cgs_stmts = mkNop } $ do { a <- fcode ; scp <- getTickScope ; return (a, scp) } @@ -725,10 +684,11 @@ getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode - = do { info_down <- getInfoDown + = do { cfg <- getStgToCmmConfig ; state <- getState + ; fcstate <- getFCodeState ; let fstate_in = state { cgs_hp_usg = initHpUsage } - (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in + (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } @@ -757,8 +717,8 @@ emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do - dflags <- getDynFlags - when (debugLevel dflags > 0) $ + debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig + when (debug_level > 0) $ emitCgStmt $ CgStmt $ CmmUnwind regs emitAssign :: CmmReg -> CmmExpr -> FCode () @@ -838,7 +798,7 @@ -- object splitting (at a later stage) getCmm code = do { state1 <- getState - ; (a, state2) <- withState code (state1 { cgs_tops = nilOL }) + ; (a, state2) <- withCgState code (state1 { cgs_tops = nilOL }) ; setState $ state2 { cgs_tops = cgs_tops state1 } ; return (a, fromOL (cgs_tops state2)) } diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -20,6 +20,7 @@ import GHC.Platform import GHC.Platform.Profile +import GHC.StgToCmm.Config import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Monad @@ -29,7 +30,6 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session -import GHC.Driver.Backend import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph @@ -77,18 +77,18 @@ -- Note [Foreign call results] cgOpApp (StgPrimOp primop) args res_ty = do - dflags <- getDynFlags + cfg <- getStgToCmmConfig cmm_args <- getNonVoidArgAmodes args - cmmPrimOpApp dflags primop cmm_args (Just res_ty) + cmmPrimOpApp cfg primop cmm_args (Just res_ty) cgOpApp (StgPrimCallOp primcall) args _res_ty = do { cmm_args <- getNonVoidArgAmodes args ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } -cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind -cmmPrimOpApp dflags primop cmm_args mres_ty = - case emitPrimOp dflags primop cmm_args of +cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind +cmmPrimOpApp cfg primop cmm_args mres_ty = + case emitPrimOp cfg primop cmm_args of PrimopCmmEmit_Internal f -> let -- if the result type isn't explicitly given, we directly use the @@ -119,8 +119,8 @@ -- Emitting code for a primop ------------------------------------------------------------------------ -shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool -shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of +shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool +shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of PrimopCmmEmit_External -> False PrimopCmmEmit_Internal _ -> True @@ -143,20 +143,22 @@ -- might happen e.g. if there's enough static information, such as statically -- know arguments. emitPrimOp - :: DynFlags + :: StgToCmmConfig -> PrimOp -- ^ The primop -> [CmmExpr] -- ^ The primop arguments -> PrimopCmmEmit -emitPrimOp dflags primop = case primop of +emitPrimOp cfg primop = + let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg) + in case primop of NewByteArrayOp_Char -> \case [(CmmLit (CmmInt n w))] - | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) + | asUnsigned w n <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> doNewByteArrayOp res (fromInteger n) _ -> PrimopCmmEmit_External NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) @@ -176,43 +178,33 @@ opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) _ -> PrimopCmmEmit_External - CopyArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - - CopyMutableArrayArrayOp -> \case - [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] -> - opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n) - _ -> PrimopCmmEmit_External - CloneArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External NewSmallArrayOp -> \case [(CmmLit (CmmInt n w)), init] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), @@ -233,25 +225,25 @@ CloneSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External CloneSmallMutableArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External FreezeSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External ThawSmallArrayOp -> \case [src, src_off, (CmmLit (CmmInt n w))] - | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) + | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n) _ -> PrimopCmmEmit_External @@ -305,14 +297,14 @@ emitPrimCall res MO_WriteBarrier [] emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var - ptrOpts <- getPtrOpts platform <- getPlatform mkdirtyMutVarCCall <- getCode $! emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] emit =<< mkCmmIfThen - (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) (closureInfoPtr ptrOpts mutv)) + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) mkdirtyMutVarCCall -- #define sizzeofByteArrayzh(r,a) \ @@ -322,7 +314,7 @@ -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes - SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp + SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -373,10 +365,6 @@ emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), mkAssign (CmmLocal res) arg ] - UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emit $ catAGraphs - [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)), - mkAssign (CmmLocal res) arg ] UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)), @@ -395,27 +383,6 @@ WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> doWritePtrArrayOp obj ix v - IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> - doReadPtrArrayOp res obj ix - WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> - doWritePtrArrayOp obj ix v - ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> doReadSmallPtrArrayOp res obj ix IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> @@ -429,17 +396,15 @@ emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) - SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp - SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp + SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) - SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp - GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp + SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp + GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp -- IndexXXXoffAddr @@ -887,7 +852,7 @@ -- SIMD primops (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res where zeros :: CmmExpr @@ -903,7 +868,7 @@ ty = vecVmmType vcat n w (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w when (es `lengthIsNot` n) $ panic "emitPrimOp: VecPackOp has wrong number of arguments" doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res @@ -921,7 +886,7 @@ ty = vecVmmType vcat n w (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w when (res `lengthIsNot` n) $ panic "emitPrimOp: VecUnpackOp has wrong number of results" doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res @@ -930,56 +895,56 @@ ty = vecVmmType vcat n w (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res where ty :: CmmType ty = vecVmmType vcat n w (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType ty = vecVmmType vcat n w (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -989,7 +954,7 @@ ty = vecCmmCat vcat w (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexByteArrayOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -999,14 +964,14 @@ ty = vecCmmCat vcat w (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteByteArrayOp Nothing ty res0 args where ty :: CmmType ty = vecCmmCat vcat w (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -1016,7 +981,7 @@ ty = vecCmmCat vcat w (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doIndexOffAddrOpAs Nothing vecty ty res0 args where vecty :: CmmType @@ -1026,7 +991,7 @@ ty = vecCmmCat vcat w (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do - checkVecCompatibility dflags vcat n w + checkVecCompatibility cfg vcat n w doWriteOffAddrOp Nothing ty res0 args where ty :: CmmType @@ -1481,92 +1446,92 @@ DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) IntQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem (wordWidth platform)) else Right (genericIntQuotRemOp (wordWidth platform)) Int8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W8) else Right (genericIntQuotRemOp W8) Int16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W16) else Right (genericIntQuotRemOp W16) Int32QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_S_QuotRem W32) else Right (genericIntQuotRemOp W32) WordQuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem (wordWidth platform)) else Right (genericWordQuotRemOp (wordWidth platform)) WordQuotRem2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowQuotRem2 then Left (MO_U_QuotRem2 (wordWidth platform)) else Right (genericWordQuotRem2Op platform) Word8QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W8) else Right (genericWordQuotRemOp W8) Word16QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W16) else Right (genericWordQuotRemOp W16) Word32QuotRemOp -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args) + if allowQuotRem && not (quotRemCanBeOptimized args) then Left (MO_U_QuotRem W32) else Right (genericWordQuotRemOp W32) WordAdd2Op -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_Add2 (wordWidth platform)) else Right genericWordAdd2Op WordAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_AddWordC (wordWidth platform)) else Right genericWordAddCOp WordSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_SubWordC (wordWidth platform)) else Right genericWordSubCOp IntAddCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_AddIntC (wordWidth platform)) else Right genericIntAddCOp IntSubCOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc)) || llvm + if allowExtAdd then Left (MO_SubIntC (wordWidth platform)) else Right genericIntSubCOp WordMul2Op -> \args -> opCallishHandledLater args $ - if ncg && (x86ish || ppc) || llvm + if allowExtAdd then Left (MO_U_Mul2 (wordWidth platform)) else Right genericWordMul2Op IntMul2Op -> \args -> opCallishHandledLater args $ - if ncg && x86ish || llvm + if allowInt2Mul then Left (MO_S_Mul2 (wordWidth platform)) else Right genericIntMul2Op FloatFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc || aarch64)) || llvm + if allowFab then Left MO_F32_Fabs else Right $ genericFabsOp W32 DoubleFabsOp -> \args -> opCallishHandledLater args $ - if (ncg && (x86ish || ppc || aarch64)) || llvm + if allowFab then Left MO_F64_Fabs else Right $ genericFabsOp W64 @@ -1600,7 +1565,6 @@ ShrinkMutableByteArrayOp_Char -> alwaysExternal ResizeMutableByteArrayOp_Char -> alwaysExternal ShrinkSmallMutableArrayOp_Char -> alwaysExternal - NewArrayArrayOp -> alwaysExternal NewMutVarOp -> alwaysExternal AtomicModifyMutVar2Op -> alwaysExternal AtomicModifyMutVar_Op -> alwaysExternal @@ -1628,7 +1592,7 @@ ReadMVarOp -> alwaysExternal TryReadMVarOp -> alwaysExternal IsEmptyMVarOp -> alwaysExternal - NewIOPortrOp -> alwaysExternal + NewIOPortOp -> alwaysExternal ReadIOPortOp -> alwaysExternal WriteIOPortOp -> alwaysExternal DelayOp -> alwaysExternal @@ -1681,8 +1645,8 @@ KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep" where - profile = targetProfile dflags - platform = profilePlatform profile + profile = stgToCmmProfile cfg + platform = stgToCmmPlatform cfg result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit @@ -1715,7 +1679,7 @@ opTranslate64 args mkMop callish = case platformWordSize platform of -- LLVM and C `can handle larger than native size arithmetic natively. - _ | not ncg -> opTranslate args $ mkMop W64 + _ | stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64 PW4 -> opCallish args callish PW8 -> opTranslate args $ mkMop W64 @@ -1769,17 +1733,11 @@ [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n) _ -> False - ncg = backend dflags == NCG - llvm = backend dflags == LLVM - x86ish = case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - _ -> False - ppc = case platformArch platform of - ArchPPC -> True - ArchPPC_64 _ -> True - _ -> False - aarch64 = platformArch platform == ArchAArch64 + allowQuotRem = stgToCmmAllowQuotRemInstr cfg + allowQuotRem2 = stgToCmmAllowQuotRem2 cfg + allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg + allowInt2Mul = stgToCmmAllowIntMul2Instr cfg + allowFab = stgToCmmAllowFabsInstrs cfg data PrimopCmmEmit -- | Out of line fake primop that's actually just a foreign call to other @@ -2046,14 +2004,14 @@ genericIntMul2Op :: GenericOp genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y] - = do dflags <- getDynFlags - platform <- getPlatform + = do cfg <- getStgToCmmConfig -- Implement algorithm from Hacker's Delight, 2nd edition, p.174 - let t = cmmExprType platform arg_x + let t = cmmExprType platform arg_x + platform = stgToCmmPlatform cfg p <- newTemp t -- 1) compute the multiplication as if numbers were unsigned _ <- withSequel (AssignTo [p, res_l] False) $ - cmmPrimOpApp dflags WordMul2Op both_args Nothing + cmmPrimOpApp cfg WordMul2Op both_args Nothing -- 2) correct the high bits of the unsigned result let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1] sub x y = CmmMachOp (MO_Sub ww) [x, y] @@ -2337,14 +2295,13 @@ -- it may very well be a design perspective that helps guide improving the NCG. -checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode () -checkVecCompatibility dflags vcat l w = do - when (backend dflags /= LLVM) $ - sorry $ unlines ["SIMD vector instructions require the LLVM back-end." - ,"Please use -fllvm."] - check vecWidth vcat l w +checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode () +checkVecCompatibility cfg vcat l w = + case stgToCmmVecInstrsErr cfg of + Nothing -> check vecWidth vcat l w -- We are in a compatible backend + Just err -> sorry err -- incompatible backend, do panic where - platform = targetPlatform dflags + platform = stgToCmmPlatform cfg check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () check W128 FloatVec 4 W32 | not (isSseEnabled platform) = sorry $ "128-bit wide single-precision floating point " ++ @@ -2352,13 +2309,13 @@ check W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2." - check W256 FloatVec _ _ | not (isAvxEnabled dflags) = + check W256 FloatVec _ _ | not (stgToCmmAvx cfg) = sorry $ "256-bit wide floating point " ++ "SIMD vector instructions require at least -mavx." - check W256 _ _ _ | not (isAvx2Enabled dflags) = + check W256 _ _ _ | not (stgToCmmAvx2 cfg) = sorry $ "256-bit wide integer " ++ "SIMD vector instructions require at least -mavx2." - check W512 _ _ _ | not (isAvx512fEnabled dflags) = + check W512 _ _ _ | not (stgToCmmAvx512f cfg) = sorry $ "512-bit wide " ++ "SIMD vector instructions require -mavx512f." check _ _ _ _ = return () @@ -2558,9 +2515,9 @@ platform <- getPlatform ifNonZero n $ do - let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1) - doByteArrayBoundsCheck ba1_off (last_touched_idx ba1_off) b8 b8 - doByteArrayBoundsCheck ba2_off (last_touched_idx ba2_off) b8 b8 + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) + doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8 + doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8 ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off @@ -2653,7 +2610,7 @@ platform <- getPlatform ifNonZero n $ do - let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1) + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 @@ -2674,7 +2631,7 @@ profile <- getProfile platform <- getPlatform ifNonZero bytes $ do - let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1) + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2695,7 +2652,7 @@ profile <- getProfile platform <- getPlatform ifNonZero bytes $ do - let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1) + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2720,7 +2677,7 @@ platform <- getPlatform doByteArrayBoundsCheck off ba b8 b8 - doByteArrayBoundsCheck (cmmAddWord platform off c) ba b8 b8 + doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8 let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off @@ -3276,9 +3233,9 @@ -> CmmExpr -- ^ array size (in elements) -> FCode () doBoundsCheck idx sz = do - dflags <- getDynFlags - platform <- getPlatform - when (gopt Opt_DoBoundsChecking dflags) (doCheck platform) + do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig + platform <- getPlatform + when do_bounds_check (doCheck platform) where doCheck platform = do boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) [] @@ -3302,7 +3259,7 @@ doPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform - let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform) + let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform) sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) doBoundsCheck idx sz @@ -3313,7 +3270,7 @@ doSmallPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform - let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform) + let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform) sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) doBoundsCheck idx sz @@ -3326,7 +3283,7 @@ doByteArrayBoundsCheck idx arr idx_ty elem_ty = do profile <- getProfile platform <- getPlatform - let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform) + let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform) sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) elem_sz = widthInBytes $ typeWidth elem_ty idx_sz = widthInBytes $ typeWidth idx_ty diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -29,11 +29,11 @@ import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit @@ -56,7 +56,9 @@ import GHC.Utils.Encoding import Control.Monad -import Data.Char (ord) +import Data.Char (ord) +import Data.Bifunctor (first) +import GHC.Utils.Monad (whenM) ----------------------------------------------------------------------------- -- @@ -72,7 +74,7 @@ ccType = bWord storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS e = mkAssign cccsReg e +storeCurCCS = mkAssign cccsReg mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -139,9 +141,9 @@ saveCurrentCostCentre :: FCode (Maybe LocalReg) -- Returns Nothing if profiling is off saveCurrentCostCentre - = do dflags <- getDynFlags - platform <- getPlatform - if not (sccProfilingEnabled dflags) + = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform + if not sccProfilingEnabled then return Nothing else do local_cc <- newTemp (ccType platform) emitAssign (CmmLocal local_cc) cccsExpr @@ -163,7 +165,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ - do profile <- targetProfile <$> getDynFlags + do profile <- getProfile let platform = profilePlatform profile profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs @@ -173,12 +175,12 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ - do profile <- targetProfile <$> getDynFlags + do profile <- getProfile let platform = profilePlatform profile let alloc_rep = rEP_CostCentreStack_mem_alloc platform emit $ addToMemE alloc_rep (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) - (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $ + (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) -- subtract the "profiling overhead", which is the -- profiling header in a closure. [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] @@ -194,21 +196,18 @@ emit $ storeCurCCS (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () -enterCostCentreFun ccs closure = - ifProfiling $ - if isCurrentCCS ccs - then do platform <- getPlatform - emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrHint), - (costCentreFrom platform closure, AddrHint)] False - else return () -- top-level function, nothing to do +enterCostCentreFun ccs closure = ifProfiling $ + when (isCurrentCCS ccs) $ + do platform <- getPlatform + emitRtsCall + rtsUnitId + (fsLit "enterFunCCS") + [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)] + False + -- otherwise we have a top-level function, nothing to do ifProfiling :: FCode () -> FCode () -ifProfiling code - = do profile <- targetProfile <$> getDynFlags - if profileIsProfiling profile - then code - else return () +ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig) --------------------------------------------------------------- -- Initialising Cost Centres & CCSs @@ -224,7 +223,7 @@ emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do - { dflags <- getDynFlags + { ctx <- stgToCmmContext <$> getStgToCmmConfig ; platform <- getPlatform ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF | otherwise = zero platform @@ -234,7 +233,7 @@ $ moduleName $ cc_mod cc) ; loc <- newByteStringCLit $ utf8EncodeString $ - showPpr dflags (costCentreSrcSpan cc) + renderWithContext ctx (ppr $! costCentreSrcSpan cc) ; let lits = [ zero platform, -- StgInt ccID, label, -- char *label, @@ -278,35 +277,39 @@ (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub +initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub -- Emit the declarations -initInfoTableProv infos itmap this_mod +initInfoTableProv infos itmap = do - dflags <- getDynFlags - let ents = convertInfoProvMap dflags infos this_mod itmap + cfg <- getStgToCmmConfig + let ents = convertInfoProvMap infos this_mod itmap + info_table = stgToCmmInfoTableMap cfg + platform = stgToCmmPlatform cfg + this_mod = stgToCmmThisModule cfg -- Output the actual IPE data mapM_ emitInfoTableProv ents -- Create the C stub which initialises the IPE map - return (ipInitCode dflags this_mod ents) + return (ipInitCode info_table platform this_mod ents) --- Info Table Prov stuff emitInfoTableProv :: InfoProvEnt -> FCode () emitInfoTableProv ip = do - { dflags <- getDynFlags - ; let mod = infoProvModule ip - ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip) - ; platform <- getPlatform - ; let mk_string = newByteStringCLit . utf8EncodeString + { cfg <- getStgToCmmConfig + ; let mod = infoProvModule ip + ctx = stgToCmmContext cfg + platform = stgToCmmPlatform cfg + ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip) + mk_string = newByteStringCLit . utf8EncodeString ; label <- mk_string label ; modl <- newByteStringCLit (bytesFS $ moduleNameFS - $ moduleName - $ mod) + $ moduleName mod) ; ty_string <- mk_string (infoTableType ip) - ; loc <- mk_string src - ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip))) - ; closure_type <- mk_string - (showPpr dflags (text $ show $ infoProvEntClosureType ip)) + ; loc <- mk_string src + ; table_name <- mk_string (renderWithContext ctx + (pprCLabel platform CStyle (infoTablePtr ip))) + ; closure_type <- mk_string (renderWithContext ctx + (text $ show $ infoProvEntClosureType ip)) ; let lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer table_name, -- char *table_name @@ -323,15 +326,12 @@ -- Set the current cost centre stack emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () -emitSetCCC cc tick push - = do profile <- targetProfile <$> getDynFlags - let platform = profilePlatform profile - if not (profileIsProfiling profile) - then return () - else do tmp <- newTemp (ccsType platform) - pushCostCentre tmp cccsExpr cc - when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) +emitSetCCC cc tick push = ifProfiling $ + do platform <- getPlatform + tmp <- newTemp (ccsType platform) + pushCostCentre tmp cccsExpr cc + when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/StgToCmm/Sequel.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- +-- Sequel type for Stg to C-- code generation +-- +-- (c) The University of Glasgow 2004-2006 +-- +-- This module is just a bucket of types used in StgToCmm.Monad and +-- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between +-- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around +-- the BlockId and LocalReg types +----------------------------------------------------------------------------- + +module GHC.StgToCmm.Sequel + ( Sequel(..) + , SelfLoopInfo + ) where + +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Ppr() + +import GHC.Types.Id +import GHC.Utils.Outputable + +import GHC.Prelude + +-------------------------------------------------------------------------------- +-- | A Sequel tells what to do with the result of this expression +data Sequel + = Return -- ^ Return result(s) to continuation found on the stack. + + | AssignTo + [LocalReg] -- ^ Put result(s) in these regs and fall through + -- NB: no void arguments here + -- + Bool -- ^ Should we adjust the heap pointer back to recover + -- space that's unused on this path? We need to do this + -- only if the expression may allocate (e.g. it's a + -- foreign call or allocating primOp) + +instance Outputable Sequel where + ppr Return = text "Return" + ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b + +type SelfLoopInfo = (Id, BlockId, [LocalReg]) +-------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -109,6 +109,7 @@ import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure +import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) import GHC.StgToCmm.Lit ( newStringCLit ) import GHC.StgToCmm.Monad @@ -128,6 +129,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Monad (whenM) -- Turgid imports for showTypeCategory import GHC.Builtin.Names @@ -138,7 +140,7 @@ import Data.Maybe import qualified Data.Char -import Control.Monad ( when ) +import Control.Monad ( when, unless ) ----------------------------------------------------------------------------- -- @@ -161,13 +163,11 @@ withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do - b <- tickyLNEIsOn + b <- isEnabled stgToCmmTickyLNE if not b then code else withNewTickyCounter TickyLNE nm args code thunkHasCounter :: Bool -> FCode Bool -thunkHasCounter isStatic = do - b <- tickyDynThunkIsOn - pure (not isStatic && b) +thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk withNewTickyCounterThunk :: Bool -- ^ static @@ -214,19 +214,18 @@ = let ctr_lbl = mkRednCountsLabel name in (>> return ctr_lbl) $ ifTicky $ do - { dflags <- getDynFlags - ; platform <- getPlatform + { cfg <- getStgToCmmConfig ; parent <- getTickyCtrLabel ; mod_name <- getModuleName -- When printing the name of a thing in a ticky file, we -- want to give the module name even for *local* things. We -- print just "x (M)" rather that "M.x" to distinguish them - -- from the global kind. - ; let ppr_for_ticky_name :: SDoc + -- from the global kind by calling to @pprTickyName@ + ; let platform = stgToCmmPlatform cfg + ppr_for_ticky_name :: SDoc ppr_for_ticky_name = - let n = ppr name - ext = case cloType of + let ext = case cloType of TickyFun single_entry -> parens $ hcat $ punctuate comma $ [text "fun"] ++ [text "se"|single_entry] TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon)) @@ -239,12 +238,9 @@ -- have a Haskell name Just pname -> text "in" <+> ppr (nameUnique pname) _ -> empty - in if isInternalName name - then n <+> parens (ppr mod_name) <+> ext <+> p - else n <+> ext <+> p + in pprTickyName mod_name name <+> ext <+> p - ; let ctx = (initSDocContext dflags defaultDumpStyle) - { sdocPprDebug = True } + ; let ctx = defaultSDocContext {sdocPprDebug = True} ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args ; emitDataLits ctr_lbl @@ -337,8 +333,8 @@ -- since the counter was registered already upon being alloc'd registerTickyCtrAtEntryDyn :: CLabel -> FCode () registerTickyCtrAtEntryDyn ctr_lbl = do - already_registered <- tickyAllocdIsOn - when (not already_registered) $ registerTickyCtr ctr_lbl + already_registered <- isEnabled stgToCmmTickyAllocd + unless already_registered $ registerTickyCtr ctr_lbl -- | Register a ticky counter. -- @@ -566,33 +562,29 @@ -- ----------------------------------------------------------------------------- -- Ticky utils -ifTicky :: FCode () -> FCode () -ifTicky code = - getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code - -tickyAllocdIsOn :: FCode Bool -tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags +isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool +isEnabled = flip fmap getStgToCmmConfig -tickyLNEIsOn :: FCode Bool -tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags +runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode () +runIfFlag f = whenM (f <$> getStgToCmmConfig) -tickyDynThunkIsOn :: FCode Bool -tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags +ifTicky :: FCode () -> FCode () +ifTicky = runIfFlag stgToCmmDoTicky ifTickyAllocd :: FCode () -> FCode () -ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code +ifTickyAllocd = runIfFlag stgToCmmTickyAllocd ifTickyLNE :: FCode () -> FCode () -ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code +ifTickyLNE = runIfFlag stgToCmmTickyLNE ifTickyDynThunk :: FCode () -> FCode () -ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code +ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkRtsCmmDataLabel lbl) +bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkRtsCmmDataLabel lbl) +bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -70,7 +70,6 @@ import GHC.Data.Graph.Directed import GHC.Utils.Misc import GHC.Types.Unique -import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -84,7 +83,6 @@ import Data.Ord import GHC.Types.Unique.Map import Data.Maybe -import GHC.Driver.Ppr import qualified Data.List.NonEmpty as NE import GHC.Core.DataCon import GHC.Types.Unique.FM @@ -99,7 +97,7 @@ -------------------------------------------------------------------------- addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph -addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n +addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl)) addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) @@ -157,12 +155,11 @@ ------------------------------------------------------------------------- emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe +emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe +emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg -- Make a call to an RTS C procedure emitRtsCallGen @@ -172,7 +169,7 @@ -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe - = do { platform <- targetPlatform <$> getDynFlags + = do { platform <- getPlatform ; updfr_off <- getUpdFrameOff ; let (caller_save, caller_load) = callerSaveVolatileRegs platform ; emit caller_save @@ -599,14 +596,14 @@ -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table. -convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] -convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = +convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] +convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = map (\cmit -> let cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) tyString :: Outputable a => a -> String - tyString t = showPpr dflags t + tyString = renderWithContext defaultSDocContext . ppr lookupClosureMap :: Maybe InfoProvEnt lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of @@ -616,7 +613,7 @@ lookupDataConMap = do UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do - (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique) + (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique -- Lookup is linear but lists will be small (< 100) return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -142,7 +142,7 @@ -- ELF specific flag, see Note [ELF needed shared libs] return (GnuGold [Option "-Wl,--no-as-needed"]) - | any ("LLD" `isPrefixOf`) stdo = + | any (\line -> "LLD" `isPrefixOf` line || "LLD" `elem` words line) stdo = return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs] "-Wl,--no-as-needed"]) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -439,6 +439,7 @@ -> TcM [EarlyDerivSpec] makeDerivSpecs deriv_infos deriv_decls = do { eqns1 <- sequenceA + -- MP: scoped_tvs here magically converts TyVar into TcTyVar [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt | DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs @@ -633,6 +634,8 @@ ; traceTc "Deriving strategy (standalone deriving)" $ vcat [ppr mb_lderiv_strat, ppr deriv_ty] ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat + ; traceTc "Deriving strategy (standalone deriving) 2" $ + vcat [ppr mb_lderiv_strat, ppr via_tvs] ; (cls_tvs, deriv_ctxt, cls, inst_tys) <- tcExtendTyVarEnv via_tvs $ tcStandaloneDerivInstType ctxt deriv_ty diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -53,13 +53,13 @@ import GHC.Types.SourceText import GHC.Driver.Session -import GHC.Builtin.Utils import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names import GHC.Builtin.Names.TH import GHC.Types.Id.Make ( coerceId ) import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Tc.Utils.Env diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -37,7 +37,6 @@ import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader -import GHC.Types.Fixity.Env import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic @@ -77,11 +76,11 @@ \end{itemize} -} -gen_Generic_binds :: GenericKind -> [Type] -> DerivInstTys +gen_Generic_binds :: GenericKind -> (Name -> Fixity) -> [Type] -> DerivInstTys -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst) -gen_Generic_binds gk inst_tys dit = do +gen_Generic_binds gk get_fixity inst_tys dit = do dflags <- getDynFlags - repTyInsts <- tc_mkRepFamInsts gk inst_tys dit + repTyInsts <- tc_mkRepFamInsts gk get_fixity inst_tys dit let (binds, sigs) = mkBindsRep dflags gk dit return (binds, sigs, repTyInsts) @@ -390,13 +389,14 @@ -- type Rep_D a b = ...representation type for D ... -------------------------------------------------------------------------------- -tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 - -> [Type] -- The type(s) to which Generic(1) is applied - -- in the generated instance - -> DerivInstTys -- Information about the last type argument, - -- including the data type's TyCon - -> TcM FamInst -- Generated representation0 coercion -tc_mkRepFamInsts gk inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = +tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 + -> (Name -> Fixity) -- Get the Fixity for a data constructor Name + -> [Type] -- The type(s) to which Generic(1) is applied + -- in the generated instance + -> DerivInstTys -- Information about the last type argument, + -- including the data type's TyCon + -> TcM FamInst -- Generated representation0 coercion +tc_mkRepFamInsts gk get_fixity inst_tys dit@(DerivInstTys{dit_rep_tc = tycon}) = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * -- ; data instance D Int a b = D_ a } @@ -426,7 +426,7 @@ where all_tyvars = tyConTyVars tycon -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * - ; repTy <- tc_mkRepTy gk_ dit arg_ki + ; repTy <- tc_mkRepTy gk_ get_fixity dit arg_ki -- `rep_name` is a name we generate for the synonym ; mod <- getModule @@ -526,6 +526,8 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1 GenericKind_ + -- Get the Fixity for a data constructor Name + -> (Name -> Fixity) -- Information about the last type argument to Generic(1) -> DerivInstTys -- The kind of the representation type's argument @@ -533,7 +535,7 @@ -> Kind -- Generated representation0 type -> TcM Type -tc_mkRepTy gk_ dit@(DerivInstTys{dit_rep_tc = tycon}) k = +tc_mkRepTy gk_ get_fixity dit@(DerivInstTys{dit_rep_tc = tycon}) k = do d1 <- tcLookupTyCon d1TyConName c1 <- tcLookupTyCon c1TyConName @@ -573,8 +575,6 @@ pDStr <- tcLookupPromDataCon decidedStrictDataConName pDUpk <- tcLookupPromDataCon decidedUnpackDataConName - fix_env <- getFixityEnv - let mkSum' a b = mkTyConApp plus [k,a,b] mkProd a b = mkTyConApp times [k,a,b] mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a @@ -631,7 +631,7 @@ ctName = mkStrLitTy . occNameFS . nameOccName . dataConName ctFix c | dataConIsInfix c - = case lookupFixity fix_env (dataConName c) of + = case get_fixity (dataConName c) of Fixity _ n InfixL -> buildFix n pLA Fixity _ n InfixR -> buildFix n pRA Fixity _ n InfixN -> buildFix n pNA diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -718,14 +718,14 @@ -> TcM ThetaType -- ^ Needed constraints (after simplification), -- i.e. @['PredType']@. simplifyDeriv pred tvs thetas - = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + = do { skol_info <- mkSkolemInfo (DerivSkol pred) + ; (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] ; let skol_set = mkVarSet tvs_skols - skol_info = DerivSkol pred doc = text "deriving" <+> parens (ppr pred) mk_given_ev :: PredType -> TcM EvVar @@ -766,7 +766,7 @@ = do { ac_given_evs <- mapM mk_given_ev ac_givens ; (_, wanteds) <- captureConstraints $ - checkConstraints skol_info ac_skols ac_given_evs $ + checkConstraints (getSkolemInfo skol_info) ac_skols ac_given_evs $ -- The checkConstraints bumps the TcLevel, and -- wraps the wanted constraints in an implication, -- when (but only when) necessary @@ -841,7 +841,7 @@ -- forall tvs. min_theta => solved_wanteds ; min_theta_vars <- mapM newEvVar min_theta ; (leftover_implic, _) - <- buildImplicationFor tc_lvl skol_info tvs_skols + <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs_skols min_theta_vars solved_wanteds -- This call to simplifyTop is purely for error reporting -- See Note [Error reporting for deriving clauses] diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -507,13 +507,18 @@ mkThetaOrigin :: CtOrigin -> TypeOrKind -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType -> ThetaOrigin -mkThetaOrigin origin t_or_k skols metas givens - = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k) +mkThetaOrigin origin t_or_k skols metas givens wanteds + = ThetaOrigin { to_anyclass_skols = skols + , to_anyclass_metas = metas + , to_anyclass_givens = givens + , to_wanted_origins = map (mkPredOrigin origin t_or_k) wanteds } -- A common case where the ThetaOrigin only contains wanted constraints, with -- no givens or locally scoped type variables. mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin -mkThetaOriginFromPreds = ThetaOrigin [] [] [] +mkThetaOriginFromPreds origins + = ThetaOrigin { to_anyclass_skols = [], to_anyclass_metas = [] + , to_anyclass_givens = [], to_wanted_origins = origins } substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin substPredOrigin subst (PredOrigin pred origin t_or_k) @@ -584,8 +589,10 @@ ; return (binds, [], deriv_stuff, field_names) } generic gen_fn _ inst_tys dit - = do { (binds, sigs, faminst) <- gen_fn inst_tys dit - ; let field_names = all_field_names (dit_rep_tc dit) + = do { let tc = dit_rep_tc dit + ; fix_env <- getDataConFixityFun tc + ; (binds, sigs, faminst) <- gen_fn fix_env inst_tys dit + ; let field_names = all_field_names tc ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) } -- See Note [Deriving and unused record selectors] @@ -626,7 +633,7 @@ -- If the TyCon is locally defined, we want the local fixity env; -- but if it is imported (which happens for standalone deriving) -- we need to get the fixity env from the interface file --- c.f. GHC.Rename.Env.lookupFixity, and #9830 +-- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994 getDataConFixityFun tc = do { this_mod <- getModule ; if nameIsLocalOrFrom this_mod name diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1,3371 +1,2229 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module GHC.Tc.Errors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - solverDepthErrorTcS - ) where - -import GHC.Prelude - -import GHC.Driver.Env (hsc_units) -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config.Diagnostic - -import GHC.Tc.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Env( tcInitTidyEnv ) -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify ( checkTyVarEq ) -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.EvTerm -import GHC.Tc.Instance.Family -import GHC.Tc.Utils.Instantiate -import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) - -import GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual - , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.Basic -import GHC.Types.Error -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) - -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) -import GHC.Unit.Module -import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Builtin.Names ( typeableClassName, pretendNameIsInScope ) -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Core.Predicate -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon - , pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys ) -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Core.ConLike ( ConLike(..)) - -import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) -import GHC.Utils.Misc -import GHC.Utils.Outputable as O -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.FV ( fvVarList, unionFV ) - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Utils.Trace (pprTraceUserWarning) -import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) -import GHC.Data.Maybe -import qualified GHC.Data.Strict as Strict - -import Control.Monad ( unless, when, foldM, forM_ ) -import Data.Foldable ( toList ) -import Data.Functor ( (<&>) ) -import Data.Function ( on ) -import Data.List ( groupBy, partition, mapAccumL - , sortBy, tails, unfoldr ) -import Data.Ord ( comparing ) --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; let type_errors | not defer_errors = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors - - ; defer_holes <- goptM Opt_DeferTypedHoles - ; let expr_holes | not defer_holes = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnTypedHoles - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; let type_holes | not partial_sigs - = ErrorWithoutFlag - | otherwise - = WarningWithFlag Opt_WarnPartialTypeSignatures - - ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope - = ErrorWithoutFlag - | otherwise - = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables - - ; report_unsolved type_errors expr_holes - type_holes out_of_scope_holes - binds_var wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- NB: Type-level holes are OK, because there are no bindings. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Fail fast on kind errors] in "GHC.Tc.Solver") -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newNoTcEvBinds - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; let type_holes | not partial_sigs = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures - - ; report_unsolved ErrorWithoutFlag - ErrorWithoutFlag type_holes ErrorWithoutFlag - ev_binds wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- "GHC.Tc.Solver" -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved WarningWithoutFlag - WarningWithoutFlag - WarningWithoutFlag - WarningWithoutFlag - ev_binds wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: DiagnosticReason -- Deferred type errors - -> DiagnosticReason -- Expression holes - -> DiagnosticReason -- Type holes - -> DiagnosticReason -- Out of scope holes - -> EvBindsVar -- cec_binds - -> WantedConstraints -> TcM () -report_unsolved type_errors expr_holes - type_holes out_of_scope_holes binds_var wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved {" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] - ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs - free_tvs = filterOut isCoVar $ - tyCoVarsOfWCList wanted - -- tyCoVarsOfWC returns free coercion *holes*, even though - -- they are "bound" by other wanted constraints. They in - -- turn may mention variables bound further in, which makes - -- no sense. Really we should not return those holes at all; - -- for now we just filter them out. - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Tidy env:" <+> ppr tidy_env - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insoluble errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in GHC.Tc.Solver.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_expand_syns = exp_syns - , cec_binds = binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted - ; traceTc "reportUnsolved }" empty } - --------------------------------------------- --- Internal functions --------------------------------------------- - --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -~~~~~~~~~~~~~~~~~~~~~~ -The idea is that error msgs are divided into three parts: the main msg, the -context block ("In the second argument of ..."), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} - -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -mk_relevant_bindings :: SDoc -> Report -mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: DiagnosticReason -- Holes in expressions. - , cec_type_holes :: DiagnosticReason -- Holes in types. - , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_expand_syns = es - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_expand_syns" <+> equals <+> ppr es - , text "cec_suppress" <+> equals <+> ppr sup ]) - --- | Returns True <=> the ReportErrCtxt indicates that something is deferred -deferringAnyBindings :: ReportErrCtxt -> Bool - -- Don't check cec_type_holes, as these don't cause bindings to be deferred -deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag - , cec_expr_holes = ErrorWithoutFlag - , cec_out_of_scope_holes = ErrorWithoutFlag }) = False -deferringAnyBindings _ = True - -maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt --- Switch off defer-type-errors inside CoEvBindsVar --- See Note [Failing equalities with no evidence bindings] -maybeSwitchOffDefer evb ctxt - | CoEvBindsVar{} <- evb - = ctxt { cec_defer_type_errors = ErrorWithoutFlag - , cec_expr_holes = ErrorWithoutFlag - , cec_out_of_scope_holes = ErrorWithoutFlag } - | otherwise - = ctxt - -{- Note [Failing equalities with no evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we go inside an implication that has no term evidence -(e.g. unifying under a forall), we can't defer type errors. You could -imagine using the /enclosing/ bindings (in cec_binds), but that may -not have enough stuff in scope for the bindings to be well typed. So -we just switch off deferred type errors altogether. See #14605. - -This is done by maybeSwitchOffDefer. It's also useful in one other -place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. - -Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) --} - -reportImplic :: ReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted, ic_binds = evb - , ic_status = status, ic_info = info - , ic_tclvl = tc_lvl }) - | BracketSkol <- info - , not insoluble - = return () -- For Template Haskell brackets report only - -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints - - | otherwise - = do { traceTc "reportImplic" (ppr implic') - ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs - -- Do /not/ use the tidied tvs because then are in the - -- wrong order, so tidying will rename things wrongly - ; reportWanteds ctxt' tc_lvl wanted - ; when (cec_warn_redundant ctxt) $ - warnRedundantConstraints ctxt' tcl_env info' dead_givens } - where - tcl_env = ic_env implic - insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $ - scopedSort tvs - -- scopedSort: the ic_skols may not be in dependency order - -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint) - -- but tidying goes wrong on out-of-order constraints; - -- so we sort them here before tidying - info' = tidySkolemInfo env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - - ctxt1 = maybeSwitchOffDefer evb ctxt - ctxt' = ctxt1 { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (#11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - - bad_telescope = case status of - IC_BadTelescope -> True - _ -> False - -warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in GHC.Tc.Solver -warnRedundantConstraints ctxt env info ev_vars - | null redundant_evs - = return () - - | SigSkol user_ctxt _ _ <- info - = setLclEnv env $ -- We want to add "In the type signature for f" - -- to the error context, which is a bit tiresome - setSrcSpan (redundantConstraintsSpan user_ctxt) $ - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } - - | otherwise -- But for InstSkol there already *is* a surrounding - -- "In the instance declaration for Eq [a]" context - -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } - where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs - - redundant_evs = - filterOut is_type_error $ - case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut (improving . idType) ev_vars - _ -> ev_vars - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () -reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt env (important doc) - ; reportDiagnostic msg } - where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols - -reportBadTelescope _ _ skol_info skols - = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, we don't report unused givens if -they can give rise to improvement. Example (#10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) -The context (Add a b ab) for the instance is clearly unused in terms -of evidence, since the dictionary has no fields. But it is still -needed! With the context, a wanted constraint - Add (Succ Zero) beta (Succ Zero) -we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. -But without the context we won't find beta := Zero. - -This only matters in instance declarations.. --} - -reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics - , wc_holes = holes }) - = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt) - , text "tidy_cts =" <+> ppr tidy_cts - , text "tidy_holes = " <+> ppr tidy_holes ]) - - -- First, deal with any out-of-scope errors: - ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes - -- don't suppress out-of-scope errors - ctxt_for_scope_errs = ctxt { cec_suppress = False } - ; (_, no_out_of_scope) <- askNoErrs $ - reportHoles tidy_cts ctxt_for_scope_errs out_of_scope - - -- Next, deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - -- (but will be by out-of-scope errors) - ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } - ; reportHoles tidy_cts ctxt_for_insols other_holes - -- holes never suppress - - ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts - - -- Now all the other constraints. We suppress errors here if - -- any of the first batch failed, or if the enclosing context - -- says to suppress - ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 - ; massertPpr (null leftovers) - (text "The following unsolved Wanted constraints \ - \have not been reported to the user:" - $$ ppr leftovers) - - -- All the Derived ones have been filtered out of simples - -- by the constraint solver. This is ok; we don't want - -- to report unsolved Derived goals as errors - -- See Note [Do not report derived but soluble errors] - - ; mapBagM_ (reportImplic ctxt2) implics } - -- NB ctxt2: don't suppress inner insolubles if there's only a - -- wanted insoluble here; but do suppress inner insolubles - -- if there's a *given* insoluble here (= inaccessible code) - where - env = cec_tidy ctxt - tidy_cts = bagToList (mapBag (tidyCt env) simples) - tidy_holes = bagToList (mapBag (tidyHole env) holes) - - -- report1: ones that should *not* be suppressed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise - -- we might suppress its error message, and proceed on past - -- type checking to get a Lint error later - report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) - - , given_eq_spec - , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) - , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) - , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) - , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) - - -- The only remaining equalities are alpha ~ ty, - -- where alpha is untouchable; and representational equalities - -- Prefer homogeneous equalities over hetero, because the - -- former might be holding up the latter. - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical - , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) - , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) - , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] - - -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- also checks to make sure the constraint isn't HoleBlockerReason - -- See TcCanonical Note [Equalities with incompatible kinds], (4) - unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool - unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False - unblocked checker ct pred = checker ct pred - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool - - is_given_eq ct pred - | EqPred {} <- pred = arisesFromGivens ct - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_user_type_error ct _ = isUserTypeErrorCt ct - - is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 - is_homo_equality _ _ = False - - is_equality _ (EqPred {}) = True - is_equality _ _ = False - - is_dict _ (ClassPred {}) = True - is_dict _ _ = False - - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - - is_FRR ct (SpecialPred ConcretePrimPred _) - | FixedRuntimeRepOrigin {} <- ctOrigin ct - = True - is_FRR _ _ - = False - - is_irred _ (IrredPred {}) = True - is_irred _ _ = False - - given_eq_spec -- See Note [Given errors] - | has_gadt_match (cec_encl ctxt) - = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) - | otherwise - = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- #13446 is an example - - -- See Note [Given errors] - has_gadt_match [] = False - has_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , ic_given_eqs implic /= NoGivenEqs - , ic_warn_inaccessible implic - -- Don't bother doing this if -Winaccessible-code isn't enabled. - -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. - = True - | otherwise - = has_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable TyVarTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = ReportErrCtxt -> [Ct] -> TcM () -type ReporterSpec - = ( String -- Name - , Ct -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location -mkSkolReporter ctxt cts - = mapM_ (reportGroup mkEqErr ctxt) (group cts) - where - group [] = [] - group (ct:cts) = (ct : yeses) : group noes - where - (yeses, noes) = partition (group_with ct) cts - - group_with ct1 ct2 - | EQ <- cmp_loc ct1 ct2 = True - | eq_lhs_type ct1 ct2 = True - | otherwise = False - -reportHoles :: [Ct] -- other (tidied) constraints - -> ReportErrCtxt -> [Hole] -> TcM () -reportHoles tidy_cts ctxt holes - = do - diag_opts <- initDiagOpts <$> getDynFlags - let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) - holes' = filter (keepThisHole severity) holes - -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` - -- because otherwise types will be zonked and tidied many times over. - (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') - let ctxt' = ctxt { cec_tidy = tidy_env' } - forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole - ; reportDiagnostic msg } - -keepThisHole :: Severity -> Hole -> Bool --- See Note [Skip type holes rapidly] -keepThisHole sev hole - = case hole_sort hole of - ExprHole {} -> True - TypeHole -> keep_type_hole - ConstraintHole -> keep_type_hole - where - keep_type_hole = case sev of - SevIgnore -> False - _ -> True - --- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole. --- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied --- type for each Id in any of the binder stacks in the 'TcLclEnv's. --- Since there is a huge overlap between these stacks, is is much, --- much faster to do them all at once, avoiding duplication. -zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type) -zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls) - where - go envs tc_bndr = case tc_bndr of - TcTvBndr {} -> return envs - TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs - TcIdBndr_ExpType name et _top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go_one name ty envs - Nothing -> return envs - } - go_one name ty (tidy_env, name_env) = do - if name `elemNameEnv` name_env - then return (tidy_env, name_env) - else do - (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty - return (tidy_env', extendNameEnv name_env name tidy_ty) - -{- Note [Skip type holes rapidly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have module with a /lot/ of partial type signatures, and we -compile it while suppressing partial-type-signature warnings. Then -we don't want to spend ages constructing error messages and lists of -relevant bindings that we never display! This happened in #14766, in -which partial type signatures in a Happy-generated parser cause a huge -increase in compile time. - -The function ignoreThisHole short-circuits the error/warning generation -machinery, in cases where it is definitely going to be a no-op. --} - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { let err = mkUserTypeError ct - ; maybeReportError ctxt ct err - ; addDeferredBinding ctxt err ct } - -mkUserTypeError :: Ct -> Report -mkUserTypeError ct = important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - -mkGivenErrorReporter :: Reporter --- See Note [Given errors] -mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called - ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) - -- For given constraints we overwrite the env (and hence src-loc) - -- with one from the immediately-enclosing implication. - -- See Note [Inaccessible code] - - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - mk_relevant_bindings binds_msg - - ; report <- mkEqErr_help ctxt report ct' ty1 ty2 - ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt - (ctLocEnv (ctLoc ct')) report - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportDiagnostic err } - where - (ct : _ ) = cts -- Never empty - (ty1, ty2) = getEqPredTys (ctPred ct) - -ignoreErrorReporter :: Reporter --- Discard Given errors that don't come from --- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt cts - = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) - ; return () } - - -{- Note [Given errors] -~~~~~~~~~~~~~~~~~~~~~~ -Given constraints represent things for which we have (or will have) -evidence, so they aren't errors. But if a Given constraint is -insoluble, this code is inaccessible, and we might want to at least -warn about that. A classic case is - - data T a where - T1 :: T Int - T2 :: T a - T3 :: T Bool - - f :: T Int -> Bool - f T1 = ... - f T2 = ... - f T3 = ... -- We want to report this case as inaccessible - -We'd like to point out that the T3 match is inaccessible. It -will have a Given constraint [G] Int ~ Bool. - -But we don't want to report ALL insoluble Given constraints. See Trac -#12466 for a long discussion. For example, if we aren't careful -we'll complain about - f :: ((Int ~ Bool) => a -> a) -> Int -which arguably is OK. It's more debatable for - g :: (Int ~ Bool) => Int -> Int -but it's tricky to distinguish these cases so we don't report -either. - -The bottom line is this: has_gadt_match looks for an enclosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) - -- Make error message for a group - -> Reporter -- Deal with lots of constraints --- Group together errors from same location, --- and report only the first (to avoid a cascade) -mkGroupReporter mk_err ctxt cts - = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - --- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) - -> Reporter -mkSuppressReporter mk_err ctxt cts - = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) - -eq_lhs_type :: Ct -> Ct -> Bool -eq_lhs_type ct1 ct2 - = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) - -cmp_loc :: Ct -> Ct -> Ordering -cmp_loc ct1 ct2 = get ct1 `compare` get ct2 - where - get ct = realSrcSpanStart (ctLocSpan (ctLoc ct)) - -- Reduce duplication by reporting only one error from each - -- /starting/ location even if the end location differs - -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter -reportGroup mk_err ctxt cts - | ct1 : _ <- cts = - do { err <- mk_err ctxt cts - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr cts - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt ct1 err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - -- Add deferred bindings for all - -- Redundant if we are going to abort compilation, - -- but that's hard to know for sure, and if we don't - -- abort, we need bindings for all (e.g. #12156) - | otherwise = panic "empty reportGroup" - --- like reportGroup, but does not actually report messages. It still adds --- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter -suppressGroup mk_err ctxt cts - = do { err <- mk_err ctxt cts - ; traceTc "Suppressing errors for" (ppr cts) - ; mapM_ (addDeferredBinding ctxt err) cts } - --- See Note [No deferring for multiplicity errors] -nonDeferrableOrigin :: CtOrigin -> Bool -nonDeferrableOrigin NonLinearPatternOrigin = True -nonDeferrableOrigin (UsageEnvironmentOf {}) = True -nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True -nonDeferrableOrigin _ = False - -maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () -maybeReportError ctxt ct report - = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic - do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag - | otherwise = cec_defer_type_errors ctxt - -- See Note [No deferring for multiplicity errors] - msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report - reportDiagnostic msg - -addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () --- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err ct - | deferringAnyBindings ctxt - , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct - -- Only add deferred bindings for Wanted constraints - = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err - ; let ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - HoleDest hole - -> do { -- See Note [Deferred errors for coercion holes] - let co_var = coHoleCoVar hole - ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkTcCoVarCo co_var) }} - - | otherwise -- Do not set any evidence for Given/Derived - = return () - -mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term - -> Report -> TcM EvTerm -mkErrorTerm ctxt ct_loc ty report - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report - -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" - ; dflags <- getDynFlags - ; let err_msg = pprLocMsgEnvelope msg - err_str = showSDoc dflags $ - err_msg $$ text "(deferred type error)" - - ; return $ evDelayedError ty err_str } - -tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters cts - = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts - ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) - ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts - ; traceTc "tryReporters }" (ppr cts') - ; return (ctxt', cts') } - where - go ctxt [] vis_cts invis_cts - = return (ctxt, vis_cts ++ invis_cts) - - go ctxt (r : rs) vis_cts invis_cts - -- always look at *visible* Origins before invisible ones - -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts - ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts - ; go ctxt'' rs vis_cts' invis_cts' } - -- Carry on with the rest, because we must make - -- deferred bindings for them if we have -fdefer-type-errors - -- But suppress their error messages - -tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) cts - | null yeses - = return (ctxt, cts) - | otherwise - = do { traceTc "tryReporter{ " (text str <+> ppr yeses) - ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after - -- See Note [Suppressing error messages] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts - -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising orig | isGivenOrigin orig = empty - | otherwise = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorReport :: DiagnosticReason - -> ReportErrCtxt - -> TcLclEnv - -> Report - -> TcM (MsgEnvelope TcRnMessage) -mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo context (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) - ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - --- This version does not include the context -mkErrorReportNC :: DiagnosticReason - -> TcLclEnv - -> Report - -> TcM (MsgEnvelope TcRnMessage) -mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = do { unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo O.empty (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) - ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - -type UserGiven = Implication - -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) - -{- Note [Always warn with -fdefer-type-errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When -fdefer-type-errors is on we warn about *all* type errors, even -if cec_suppress is on. This can lead to a lot more warnings than you -would get errors without -fdefer-type-errors, but if we suppress any of -them you might get a runtime error that wasn't warned about at compile -time. - -To be consistent, we should also report multiple warnings from a single -location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! - -With #10283, you can now opt out of deferred type error warnings. - -Note [No deferring for multiplicity errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify, -linear types do not support casts and any nontrivial coercion will raise -an error during desugaring. - -This means that even if we defer a multiplicity mismatch during typechecking, -the desugarer will refuse to compile anyway. Worse: the error raised -by the desugarer would shadow the type mismatch warnings (#20083). -As a solution, we refuse to defer submultiplicity constraints. Test: T20083. - -To determine whether a constraint arose from a submultiplicity check, we -look at the CtOrigin. All calls to tcSubMult use one of two origins, -UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not -used outside of linear types. - -In the future, we should compile 'WpMultCoercion' to a runtime error with --fdefer-type-errors, but the current implementation does not always -place the wrapper in the right place and the resulting program can fail Lint. -This plan is tracked in #20083. - -Note [Deferred errors for coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we need to defer a type error where the destination for the evidence -is a coercion hole. We can't just put the error in the hole, because we can't -make an erroneous coercion. (Remember that coercions are erased for runtime.) -Instead, we invent a new EvVar, bind it to an error and then make a coercion -from that EvVar, filling the hole with that coercion. Because coercions' -types are unlifted, the error is guaranteed to be hit before we get to the -coercion. - -Note [Do not report derived but soluble errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wc_simples include Derived constraints that have not been solved, -but are not insoluble (in that case they'd be reported by 'report1'). -We do not want to report these as errors: - -* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have - an unsolved [D] Eq a, and we do not want to report that; it's just noise. - -* Functional dependencies. For givens, consider - class C a b | a -> b - data T a where - MkT :: C a d => [d] -> T a - f :: C a b => T a -> F Int - f (MkT xs) = length xs - Then we get a [D] b~d. But there *is* a legitimate call to - f, namely f (MkT [True]) :: T Bool, in which b=d. So we should - not reject the program. - - For wanteds, something similar - data T a where - MkT :: C Int b => a -> b -> T a - g :: C Int c => c -> () - f :: T a -> () - f (MkT x y) = g x - Here we get [G] C Int b, [W] C Int a, hence [D] a~b. - But again f (MkT True True) is a legitimate call. - -(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose -derived superclasses between iterations of the solver.) - -For functional dependencies, here is a real example, -stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs - - class C a b | a -> b - g :: C a b => a -> b -> () - f :: C a b => a -> b -> () - f xa xb = - let loop = g xa - in loop xb - -We will first try to infer a type for loop, and we will succeed: - C a b' => b' -> () -Subsequently, we will type check (loop xb) and all is good. But, -recall that we have to solve a final implication constraint: - C a b => (C a b' => .... cts from body of loop .... )) -And now we have a problem as we will generate an equality b ~ b' and fail to -solve it. - - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkIrredErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; return $ msg `mappend` mk_relevant_bindings binds_msg } - where - (ct1:_) = cts - -{- Note [Constructing Hole Errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms, -these "hole" errors are /not/ suppressed by cec_suppress. We want to see them! - -There are two cases to consider: - -1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on, - in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning - only if -Wout-of-scope-variables is on. - -2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated - for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case - the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on. - -The above can be summarised into the following table: - -| Hole Type | Active Flags | Outcome | -|--------------|----------------------------------------------------------|------------------| -| out-of-scope | None | Error | -| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning | -| out-of-scope | -fdefer-out-of-scope-variables | Ignore (discard) | -| type | None | Error | -| type | -XPartialTypeSignatures, -Wpartial-type-signatures | Warning | -| type | -XPartialTypeSignatures | Ignore (discard) | -| expression | None | Error | -| expression | -Wdefer-typed-holes, -Wtyped-holes | Warning | -| expression | -Wdefer-typed-holes | Ignore (discard) | - -See also 'reportUnsolved'. - --} - ----------------- --- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. -mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) -mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_loc = ct_loc }) - | isOutOfScopeHole hole - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; let err = important out_of_scope_msg `mappend` - (mk_relevant_bindings $ - unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) - - ; maybeAddDeferredBindings ctxt hole err - ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err - -- Use NC variant: the context is generally not helpful here - } - where - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) - - lcl_env = ctLocEnv ct_loc - boring_type = isTyVarTy hole_ty - - -- general case: not an out-of-scope error -mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_sort = sort - , hole_loc = ct_loc }) - = do { binds_msg - <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) - -- The 'False' means "don't filter the bindings"; see Trac #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg - | ExprHole _ <- sort, show_hole_constraints - = givenConstraintsMsg ctxt - | otherwise - = empty - - ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples hole - else return (ctxt, empty) - - ; let err = important hole_msg `mappend` - mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg - - ; maybeAddDeferredBindings ctxt hole err - - ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt - | otherwise = cec_type_holes ctxt - ; mkErrorReport holes ctxt lcl_env err - } - - where - lcl_env = ctLocEnv ct_loc - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - - hole_msg = case sort of - ExprHole _ -> vcat [ hang (text "Found hole:") - 2 (pp_occ_with_type occ hole_ty) - , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for") - 2 (quotes $ pprType hole_ty) -- always kind constraint - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | ErrorWithoutFlag <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - - -{- Note [Adding deferred bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When working with typed holes we have to deal with the case where -we want holes to be reported as warnings to users during compile time but -as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings' -so that the correct 'Severity' can be computed out of that later on. - --} - - --- | Adds deferred bindings (as errors). --- See Note [Adding deferred bindings]. -maybeAddDeferredBindings :: ReportErrCtxt - -> Hole - -> Report - -> TcM () -maybeAddDeferredBindings ctxt hole report = do - case hole_sort hole of - ExprHole (HER ref ref_ty _) -> do - -- Only add bindings for holes in expressions - -- not for holes in partial type signatures - -- cf. addDeferredBinding - when (deferringAnyBindings ctxt) $ do - err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report - -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. - -- See Note [Holes] in GHC.Tc.Types.Constraint - writeMutVar ref err_tm - _ -> pure () - -pp_occ_with_type :: OccName -> Type -> SDoc -pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - --- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module --- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Hole -- The hole - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. -validHoleFits ctxt@(CEC {cec_encl = implics - , cec_tidy = lcl_env}) simps hole - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole - ; return (ctxt {cec_tidy = tidy_env}, msg) } - --- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) - ----------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkIPErr ctxt cts - = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = important $ addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - - ; return $ msg `mappend` mk_relevant_bindings binds_msg } - where - (ct1:_) = cts - ----------------- - --- | Create a user-facing error message for unsolved @'Concrete#' ki@ --- Wanted constraints arising from representation-polymorphism checks. --- --- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkFRRErr ctxt cts - = do { -- Zonking/tidying. - ; origs <- - -- Zonk/tidy the 'CtOrigin's. - zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) - <&> - -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. - (nubOrdBy (nonDetCmpType `on` frr_type) . snd) - - -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), - -- with the corresponding types: - -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... - ; let tys = map frr_type origs - kis = map typeKind tys - - -- Assemble the error message: pair up each origin with the corresponding type, e.g. - -- • FixedRuntimeRep origin msg 1 ... - -- a :: TYPE r1 - -- • FixedRuntimeRep origin msg 2 ... - -- b :: TYPE r2 - - combine_origin_ty_ki :: CtOrigin -> Type -> Kind -> SDoc - combine_origin_ty_ki orig ty ki = - -- Add bullet points if there is more than one error. - (if length tys > 1 then (bullet <+>) else id) $ - vcat [pprArising orig <> colon - ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE ki] - - msg :: SDoc - msg = vcat $ zipWith3 combine_origin_ty_ki origs tys kis - - ; return $ important msg } - where - - frr_type :: CtOrigin -> Type - frr_type (FixedRuntimeRepOrigin ty _) = ty - frr_type orig - = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" - (text "origin =" <+> ppr orig) - -{- -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (#7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct -mkEqErr _ [] = panic "mkEqErr" - -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report -mkEqErr1 ctxt ct -- Wanted or derived; - -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; let coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) - ; let report = mconcat [ important coercible_msg - , mk_relevant_bindings binds_msg] - ; mkEqErr_help ctxt report ct ty1 ty2 } - where - (ty1, ty2) = getEqPredTys (ctPred ct) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") - | otherwise - = empty - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -mkEqErr_help :: ReportErrCtxt -> Report - -> Ct - -> TcType -> TcType -> TcM Report -mkEqErr_help ctxt report ct ty1 ty2 - | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt report ct tv1 ty2 - | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt report ct tv2 ty1 - | otherwise - = return $ reportEqErr ctxt report ct ty1 ty2 - -reportEqErr :: ReportErrCtxt -> Report - -> Ct - -> TcType -> TcType -> Report -reportEqErr ctxt report ct ty1 ty2 - = mconcat [misMatch, report, eqInfo] - where - misMatch = misMatchOrCND False ctxt ct ty1 ty2 - eqInfo = mkEqInfoMsg ct ty1 ty2 - -mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM Report --- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt report ct tv1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; dflags <- getDynFlags - ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } - -mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> Report -mkTyVarEqErr' dflags ctxt report ct tv1 ty2 - -- impredicativity is a simple error to understand; try it first - | check_eq_result `cterHasProblem` cteImpredicative - = let msg = vcat [ (if isSkolemTyVar tv1 - then text "Cannot equate type variable" - else text "Cannot instantiate unification variable") - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] - in - -- Unlike the other reports, this discards the old 'report_important' - -- instead of augmenting it. This is because the details are not likely - -- to be helpful since this is just an unimplemented feature. - mconcat [ headline_msg - , important msg - , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty - , report ] - - | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have - -- swapped in Solver.Canonical.canEqTyVarHomo - || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || ctEqRel ct == ReprEq - -- The cases below don't really apply to ReprEq (except occurs check) - = mconcat [ headline_msg - , extraTyVarEqInfo ctxt tv1 ty2 - , suggestAddSig ctxt ty1 ty2 - , report - ] - - | cterHasOccursCheck check_eq_result - -- We report an "occurs check" even for a ~ F t a, where F is a type - -- function; it's not insoluble (because in principle F could reduce) - -- but we have certainly been unable to solve it - = let extra2 = mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = mk_relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - in - mconcat [headline_msg, extra2, extra3, report] - - -- If the immediately-enclosing implication has 'tv' a skolem, and - -- we know by now its an InferSkol kind of skolem, then presumably - -- it started life as a TyVarTv, else it'd have been unified, given - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = mconcat [ misMatchMsg ctxt ct ty1 ty2 - , extraTyVarEqInfo ctxt tv1 ty2 - , report - ] - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = let msg = misMatchMsg ctxt ct ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - in - mconcat [msg, tv_extra, report] - - -- Nastiest case: attempt to unify an untouchable variable - -- So tv is a meta tyvar (or started that way before we - -- generalised it). So presumably it is an *untouchable* - -- meta tyvar or a TyVarTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic - = assertPpr (not (isTouchableMetaTyVar lvl tv1)) - (ppr tv1 $$ ppr lvl) $ -- See Note [Error messages for untouchables] - let msg = misMatchMsg ctxt ct ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = extraTyVarEqInfo ctxt tv1 ty2 - add_sig = suggestAddSig ctxt ty1 ty2 - in - mconcat [msg, tclvl_extra, tv_extra, add_sig, report] - - | otherwise - = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 - -- This *can* happen (#6123) - -- Consider an ambiguous top-level constraint (a ~ F a) - -- Not an occurs check, because F is a type function. - where - headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 - - ty1 = mkTyVarTy tv1 - - check_eq_result = case ct of - CIrredCan { cc_reason = NonCanonicalReason result } -> result - CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker - _ -> checkTyVarEq dflags tv1 ty2 - -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type - -- variable is on the right, so we don't get useful info for the CIrredCan, - -- and have to compute the result of checkTyVarEq here. - - - insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs - - what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel - -levelString :: TypeOrKind -> String -levelString TypeLevel = "type" -levelString KindLevel = "kind" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> Report --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = important (tyfun_msg $$ ambig_msg) - where - mb_fun1 = isTyFun_maybe ty1 - mb_fun2 = isTyFun_maybe ty2 - - ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty - -misMatchOrCND :: Bool -> ReportErrCtxt -> Ct - -> TcType -> TcType -> Report --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 - | insoluble_occurs_check -- See Note [Insoluble occurs check] - || (isRigidTy ty1 && isRigidTy ty2) - || isGivenCt ct - || null givens - = -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - misMatchMsg ctxt ct ty1 ty2 - - | otherwise - = mconcat [ couldNotDeduce givens ([eq_pred], orig) - , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ] - where - ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev - level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel - givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] - -- Keep only UserGivens that have some equalities. - -- See Note [Suppress redundant givens during error reporting] - -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report -couldNotDeduce givens (wanteds, orig) - = important $ - vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - --- These are for the "blocked" equalities, as described in TcCanonical --- Note [Equalities with incompatible kinds], wrinkle (2). There should --- always be another unsolved wanted around, which will ordinarily suppress --- this message. But this can still be printed out with -fdefer-type-errors --- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkBlockedEqErr _ (ct:_) = return $ important msg - where - msg = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) - , text "Doing so would be ill-kinded." ] - -- This is a terrible message. Perhaps worse, if the user - -- has -fprint-explicit-kinds on, they will see that the two - -- sides have the same kind, as there is an invisible cast. - -- I really don't know how to do better. -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" - -{- -Note [Suppress redundant givens during error reporting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC is unable to solve a constraint and prints out an error message, it -will print out what given constraints are in scope to provide some context to -the programmer. But we shouldn't print out /every/ given, since some of them -are not terribly helpful to diagnose type errors. Consider this example: - - foo :: Int :~: Int -> a :~: b -> a :~: c - foo Refl Refl = Refl - -When reporting that GHC can't solve (a ~ c), there are two givens in scope: -(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., -redundant), so it's not terribly useful to report it in an error message. -To accomplish this, we discard any Implications that do not bind any -equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_given_eqs` field of the Implication). Note that we discard givens -that have no equalities whatsoever, but we want to keep ones with only *local* -equalities, as these may be helpful to the user in understanding what went -wrong. - -But this is not enough to avoid all redundant givens! Consider this example, -from #15361: - - goo :: forall (a :: Type) (b :: Type) (c :: Type). - a :~~: b -> a :~~: c - goo HRefl = HRefl - -Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. -The (* ~ *) part arises due the kinds of (:~~:) being unified. More -importantly, (* ~ *) is redundant, so we'd like not to report it. However, -the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_given_eqs field), so the test above will keep it wholesale. - -To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) -part. This works because mkMinimalBySCs eliminates reflexive equalities in -addition to superclasses (see Note [Remove redundant provided dicts] -in GHC.Tc.TyCl.PatSyn). --} - -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2) - where - ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = assertPpr (isTyVar tv) (ppr tv) $ - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 _ty2 - | null inferred_bndrs -- No let-bound inferred binders in context - = mempty - | [bndr] <- inferred_bndrs - = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr) - | otherwise - = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) - where - inferred_bndrs = case tcGetTyVar_maybe ty1 of - Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv - _ -> [] - - -- 'find' returns the binders of an InferSkol for 'tv', - -- provided there is an intervening implication with - -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) - find [] _ _ = [] - find (implic:implics) seen_eqs tv - | tv `elem` ic_skols implic - , InferSkol prs <- ic_info implic - , seen_eqs - = map fst prs - | otherwise - = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv - --------------------- -misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ctxt ct ty1 ty2 - = important $ - addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 orig $ - sep [ case orig of - TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - _ -> headline_eq_msg False ct ty1 ty2 - , sameOccExtra ty2 ty1 ] - where - orig = ctOrigin ct - -headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc --- Generates the main "Could't match 't1' against 't2' --- headline message -headline_eq_msg add_ea ct ty1 ty2 - - | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || - (isLiftedLevity ty1 && isUnliftedLevity ty2) || - (isLiftedLevity ty2 && isUnliftedLevity ty1) - = text "Couldn't match a lifted type with an unlifted type" - - | isAtomicTy ty1 || isAtomicTy ty2 - = -- Print with quotes - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) ] - - | otherwise - = -- Print with vertical layout - vcat [ text herald1 <> colon <+> ppr ty1 - , nest padding $ - text herald2 <> colon <+> ppr ty2 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if add_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if add_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - -tk_eq_msg :: ReportErrCtxt - -> Ct -> Type -> Type -> CtOrigin -> SDoc -tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = mb_thing }) - -- We can use the TypeEqOrigin to - -- improve the error message quite a lot - - | isUnliftedTypeKind act, isLiftedTypeKind exp - = sep [ text "Expecting a lifted type, but" - , thing_msg mb_thing (text "an") (text "unlifted") ] - - | isLiftedTypeKind act, isUnliftedTypeKind exp - = sep [ text "Expecting an unlifted type, but" - , thing_msg mb_thing (text "a") (text "lifted") ] - - | tcIsLiftedTypeKind exp - = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , case mb_thing of - Nothing -> text "found something with kind" - Just thing -> quotes thing <+> text "has kind" - , quotes (pprWithTYPE act) ] - - | Just nargs_msg <- num_args_msg - = nargs_msg $$ - mk_ea_msg ctxt (Just ct) level orig - - | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ - ea_looks_same ty1 ty2 exp act - = mk_ea_msg ctxt (Just ct) level orig - - | otherwise -- The mismatched types are /inside/ exp and act - = vcat [ headline_eq_msg False ct ty1 ty2 - , mk_ea_msg ctxt Nothing level orig ] - - where - ct_loc = ctLoc ct - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - thing_msg (Just thing) _ levity = quotes thing <+> text "is" <+> levity - thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- mb_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - -tk_eq_msg ctxt ct ty1 ty2 - (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k) - = vcat [ headline_eq_msg False ct ty1 ty2 - , supplementary_msg ] - where - sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel - sub_whats = text (levelString sub_t_or_k) <> char 's' - -- "types" or "kinds" - - supplementary_msg - = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - if printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - then vcat [ hang (text "When matching" <+> sub_whats) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ] - else text "When matching the kind of" <+> quotes (ppr cty1) - -tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg" - -ea_looks_same :: Type -> Type -> Type -> Type -> Bool --- True if the faulting types (ty1, ty2) look the same as --- the expected/actual types (exp, act). --- If so, we don't want to redundantly report the latter -ea_looks_same ty1 ty2 exp act - = (act `looks_same` ty1 && exp `looks_same` ty2) || - (exp `looks_same` ty1 && act `looks_same` ty2) - where - looks_same t1 t2 = t1 `pickyEqType` t2 - || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind - -- pickyEqType is sensitive to synonyms, so only replies True - -- when the types really look the same. However, - -- (TYPE 'LiftedRep) and Type both print the same way. - -mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> SDoc -mk_supplementary_ea_msg ctxt level ty1 ty2 orig - | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig - , not (ea_looks_same ty1 ty2 exp act) - = mk_ea_msg ctxt Nothing level orig - | otherwise - = empty - -mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc --- Constructs a "Couldn't match" message --- The (Maybe Ct) says whether this is the main top-level message (Just) --- or a supplementary message (Nothing) -mk_ea_msg ctxt at_top level - (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) - | Just thing <- mb_thing - , KindLevel <- level - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes thing <+> text "has kind" <+> - quotes (ppr act)) - - | otherwise - = vcat [ case at_top of - Just ct -> headline_eq_msg True ct exp act - Nothing -> supplementary_ea_msg - , ppWhen expand_syns expandedTys ] - - where - supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] - - kind_desc | tcIsConstraintKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - - expand_syns = cec_expand_syns ctxt - - expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mk_ea_msg _ _ _ _ = empty - --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. --- --- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin', and if so, uses the expected/actual types from that to --- check for a kind mismatch (as these types typically have more surrounding --- types and are likelier to be able to glean information about whether a --- mismatch occurred in an invisible argument position or not). If the --- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types --- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds - where - (act_ty, exp_ty) = case ct of - TypeEqOrigin { uo_actual = act - , uo_expected = exp } -> (act, exp) - _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type - -{- Note [Insoluble occurs check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble -so we don't use it for rewriting. The Wanted is also insoluble, and -we don't solve it from the Given. It's very confusing to say - Cannot solve a ~ [a] from given constraints a ~ [a] - -And indeed even thinking about the Givens is silly; [W] a ~ [a] is -just as insoluble as Int ~ Bool. - -Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) -then report it directly, not in the "cannot deduce X from Y" form. -This is done in misMatchOrCND (via the insoluble_occurs_check arg) - -(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't -want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - , tys1 `equalLength` tys2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. The lengths of tys1 and tys2 must be equal; - -- for example, with type S a = a, we don't want - -- to zip (S Monad Int) and (S Bool). - let (tys1', tys2') = - unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc --- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnit) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnit mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -More specifically, we suggest adding a type sig if we have p ~ ty, and -p is a skolem bound by an InferSkol. Those skolems were created from -unification variables in simplifyInfer. Why didn't we unify? It must -have been because of an intervening GADT or existential, making it -untouchable. Either way, a type signature would help. For GADTs, it -might make it typeable; for existentials the attempt to write a -signature will fail -- or at least will produce a better error message -next time - -This initially came up in #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM Report -mkDictErr ctxt cts - = assert (not (null cts)) $ - do { inst_envs <- tcGetInstEnvs - ; let min_cts = elim_superclasses cts - lookups = map (lookup_cls_inst inst_envs) min_cts - (no_inst_cts, overlap_cts) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- But we report only one of them (hence 'head') because they all - -- have the same source-location origin, to try avoid a cascade - -- of error from one location - ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; return $ important err } - where - no_givens = null (getUserGivens ctxt) - - is_no_inst (ct, (matches, unifiers, _)) - = no_givens - && null matches - && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) - - lookup_cls_inst inst_envs ct - = (ct, lookupInstEnv True inst_envs clas tys) - where - (clas, tys) = getClassPredTys (ctPred ct) - - - -- When simplifying [W] Ord (Set a), we need - -- [W] Eq a, [W] Ord a - -- but we really only want to report the latter - elim_superclasses cts = mkMinimalBySCs ctPred cts - --- [Note: mk_dict_err] --- ~~~~~~~~~~~~~~~~~~~ --- Different dictionary error messages are reported depending on the number of --- matches and unifiers: --- --- - No matches, regardless of unifiers: report "No instance for ...". --- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", --- and show the matching and unifying instances. --- - One match, one or more unifiers: report "Overlapping instances for", show the --- matching and unifying instances, and say "The choice depends on the instantion of ..., --- and the result of evaluating ...". -mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM SDoc --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct - ; candidate_insts <- get_candidate_instances - ; field_suggestions <- record_field_suggestions - ; return (cannot_resolve_msg ct candidate_insts binds_msg field_suggestions) } - - | null unsafe_overlapped -- Some matches => overlap errors - = return overlap_msg - - | otherwise - = return safe_haskell_msg - where - orig = ctOrigin ct - pred = ctPred ct - (clas, tys) = getClassPredTys pred - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: TcM SDoc - record_field_suggestions = flip (maybe $ return empty) record_field $ \name -> - do { glb_env <- getGlobalRdrEnv - ; lcl_env <- getLocalRdrEnv - ; if occ_name_in_scope glb_env lcl_env name - then return empty - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } - - occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGlobalRdrEnv glb_env occ_name) && - isNothing (lookupLocalRdrOcc lcl_env occ_name) - - record_field = case orig of - HasFieldOrigin name -> Just (mkVarOccFS name) - _ -> Nothing - - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg field_suggestions - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) - -- See Note [Report candidate instances] - , field_suggestions ] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - potential_hdr $$ - potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) - - potential_hdr - = ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- Normal overlap error - overlap_msg - = assert (not (null matches)) $ - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , potentialInstancesErrMsg - (PotentialInstances { matches = map fst matches, unifiers }) - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ ppUnless (null tyCoVars) $ - text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr tyCoVars) - , ppUnless (null famTyCons) $ - if (null tyCoVars) - then - text "The choice depends on the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - else - text "and the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - where - tyCoVars = tyCoVarsOfTypesList tys - famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -{- Note [Report candidate instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved (Num Int), where `Int` is not the Prelude Int, -but comes from some other module, then it may be helpful to point out -that there are some similarly named instances elsewhere. So we get -something like - No instance for (Num Int) arising from the literal ‘3’ - There are instances for similar types: - instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ -Discussion in #9611. - -Note [Highlighting ambiguous type variables] -~------------------------------------------- -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - -Note [Out-of-scope fields with -XOverloadedRecordDot] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XOverloadedRecordDot, when a field isn't in scope, the error that appears -is produces here, and it says - No instance for (GHC.Record.HasField "" ...). - -Additionally, though, we want to suggest similar field names that are in scope -or could be in scope with different import lists. - -However, we can still get an error about a missing HasField instance when a -field is in scope (if the types are wrong), and so it's important that we don't -suggest similar names here if the record field is in scope, either qualified or -unqualified, since qualification doesn't matter for -XOverloadedRecordDot. - -Example: - - import Data.Monoid (Alt(..)) - - foo = undefined.getAll - -results in - - No instance for (GHC.Records.HasField "getAll" r0 a0) - arising from selecting the field ‘getAll’ - Perhaps you meant ‘getAlt’ (imported from Data.Monoid) - Perhaps you want to add ‘getAll’ to the import list - in the import of ‘Data.Monoid’ --} - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - - --- | This datatype collates instances that match or unifier, --- in order to report an error message for an unsolved typeclass constraint. -data PotentialInstances - = PotentialInstances - { matches :: [ClsInst] - , unifiers :: [ClsInst] - } - --- | Directly display the given matching and unifying instances, --- with a header for each: `Matching instances`/`Potentially matching instances`. -pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc -pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = - vcat - [ ppWhen (not $ null matches) $ - text "Matching instance" <> plural matches <> colon $$ - nest 2 (vcat (map ppr_inst matches)) - , ppWhen (not $ null unifiers) $ - (text "Potentially matching instance" <> plural unifiers <> colon) $$ - nest 2 (vcat (map ppr_inst unifiers)) - ] - --- | Display a summary of available instances, omitting those involving --- out-of-scope types, in order to explain why we couldn't solve a particular --- constraint, e.g. due to instance overlap or out-of-scope types. --- --- To directly display a collection of matching/unifying instances, --- use 'pprPotentialInstances'. -potentialInstancesErrMsg :: PotentialInstances -> SDoc --- See Note [Displaying potential instances] -potentialInstancesErrMsg potentials = - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - potentials_msg_with_options potentials print_insts sty - --- | Display a summary of available instances, omitting out-of-scope ones. --- --- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing --- options. -potentials_msg_with_options :: PotentialInstances - -> Bool -- ^ Whether to print /all/ potential instances - -> PprStyle - -> SDoc -potentials_msg_with_options - (PotentialInstances { matches, unifiers }) - show_all_potentials sty - | null matches && null unifiers - = empty - - | null show_these_matches && null show_these_unifiers - = vcat [ not_in_scope_msg empty - , flag_hint ] - - | otherwise - = vcat [ pprPotentialInstances - pprInstance -- print instance + location info - (PotentialInstances - { matches = show_these_matches - , unifiers = show_these_unifiers }) - , overlapping_but_not_more_specific_msg sorted_matches - , nest 2 $ vcat - [ ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , ppWhen (not_in_scopes > 0) $ - not_in_scope_msg (text "...plus") - , flag_hint ] ] - where - n_show_matches, n_show_unifiers :: Int - n_show_matches = 3 - n_show_unifiers = 2 - - (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches - (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers - sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches - sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers - (show_these_matches, show_these_unifiers) - | show_all_potentials = (sorted_matches, sorted_unifiers) - | otherwise = (take n_show_matches sorted_matches - ,take n_show_unifiers sorted_unifiers) - n_in_scope_hidden - = length sorted_matches + length sorted_unifiers - - length show_these_matches - length show_these_unifiers - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | pretendNameIsInScope name - = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scopes :: Int - not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers - - not_in_scope_msg herald = - hang (herald <+> speakNOf not_in_scopes (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_all_potentials $ - pprPotentialInstances - pprInstanceHdr -- only print the header, not the instance location info - (PotentialInstances - { matches = not_in_scope_matches - , unifiers = not_in_scope_unifiers - })) - - flag_hint = ppUnless (show_all_potentials - || (equalLength show_these_matches matches - && equalLength show_these_unifiers unifiers)) $ - text "(use -fprint-potential-instances to see them all)" - --- | Compute a message informing the user of any instances that are overlapped --- but were not discarded because the instance overlapping them wasn't --- strictly more specific. -overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc -overlapping_but_not_more_specific_msg insts - -- Only print one example of "overlapping but not strictly more specific", - -- to avoid information overload. - | overlap : _ <- overlapping_but_not_more_specific - = overlap_header $$ ppr_overlapping overlap - | otherwise - = empty - where - overlap_header :: SDoc - overlap_header - | [_] <- overlapping_but_not_more_specific - = text "An overlapping instance can only be chosen when it is strictly more specific." - | otherwise - = text "Overlapping instances can only be chosen when they are strictly more specific." - overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] - overlapping_but_not_more_specific - = nubOrdBy (comparing (is_dfun . fst)) - [ (overlapper, overlappee) - | these <- groupBy ((==) `on` is_cls_nm) insts - -- Take all pairs of distinct instances... - , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` - , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` - -- ... such that one instance in the pair overlaps the other... - , let mb_overlapping - | hasOverlappingFlag (overlapMode $ is_flag one) - || hasOverlappableFlag (overlapMode $ is_flag other) - = [(one, other)] - | hasOverlappingFlag (overlapMode $ is_flag other) - || hasOverlappableFlag (overlapMode $ is_flag one) - = [(other, one)] - | otherwise - = [] - , (overlapper, overlappee) <- mb_overlapping - -- ... but the overlapper is not more specific than the overlappee. - , not (overlapper `more_specific_than` overlappee) - ] - more_specific_than :: ClsInst -> ClsInst -> Bool - is1 `more_specific_than` is2 - = isJust (tcMatchTys (is_tys is1) (is_tys is2)) - ppr_overlapping :: (ClsInst, ClsInst) -> SDoc - ppr_overlapping (overlapper, overlappee) - = text "The first instance that follows overlaps the second, but is not more specific than it:" - $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus N others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- -Note [Kind arguments in error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (#9171) - - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. - -To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -the above error message would instead be displayed as: - - Couldn't match expected type - ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ - with actual type - ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ - -Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. --} - -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (UnkSkol, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "(rigid, skolem)") - , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) - ] - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -getAmbigTkvs :: Ct -> ([Var],[Var]) -getAmbigTkvs ct - = partition (`elemVarSet` dep_tkv_set) ambig_tkvs - where - tkvs = tyCoVarsOfCtList ct - ambig_tkvs = filter isAmbiguousTyVar tkvs - dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info - pprTraceUserWarning msg [(UnkSkol,tvs)] - where - msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ------------------------ --- relevantBindings looks at the value environment and finds values whose --- types mention any of the offending type variables. It has to be --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See #8191 - -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt ct - = do { traceTc "relevantBindings" (ppr ct) - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - ; let extra_tvs = case tidy_orig of - KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] - _ -> emptyVarSet - ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs - - -- Put a zonked, tidied CtOrigin into the Ct - loc' = setCtLocOrigin loc tidy_orig - ct' = setCtLoc ct loc' - - ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] - - ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs - ; let ctxt' = ctxt { cec_tidy = env2 } - ; return (ctxt', doc, ct') } - where - loc = ctLoc ct - lcl_env = ctLocEnv loc - --- slightly more general version, to work also with holes -relevant_bindings :: Bool - -> TcLclEnv - -> NameEnv Type -- Cache of already zonked and tidied types - -> TyCoVarSet - -> TcM SDoc -relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs - = do { dflags <- getDynFlags - ; traceTc "relevant_bindings" $ - vcat [ ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; (docs, discards) - <- go dflags (maxRelevantBinds dflags) - emptyVarSet [] False - (removeBindingShadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - ; return doc } - where - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - - go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel - -> [TcBinder] - -> TcM ([SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ _ _ docs discards [] - = return (reverse docs, discards) - go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs) - = case tc_bndr of - TcTvBndr {} -> discard_it - TcIdBndr id top_lvl -> go2 (idName id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just _ty -> go2 name top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags n_left tvs_seen docs - discards tc_bndrs - go2 id_name top_lvl - = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of - Just tty -> tty - Nothing -> pprPanic "relevant_bindings" (ppr id_name) - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags n_left tvs_seen docs - True -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - ------------------------ -warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () -warnDefaulting the_tv wanteds default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag wanteds) - tidy_wanteds = map (tidyCt tidy_env) wanteds - tidy_tv = lookupVarEnv (snd tidy_env) the_tv - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep $ [ text "Defaulting" ] - ++ - (case tidy_tv of - Nothing -> [] - Just tv -> [text "the type variable" - , quotes (ppr tv)]) - ++ - [ text "to type" - , quotes (ppr default_ty) - , text "in the following constraint" <> plural tidy_wanteds ]) - 2 - ppr_wanteds - ; let diag = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnTypeDefaults) noHints warn_msg +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ParallelListComp #-} + +module GHC.Tc.Errors( + reportUnsolved, reportAllUnsolved, warnAllUnsolved, + warnDefaulting, + + solverDepthErrorTcS + ) where + +import GHC.Prelude + +import GHC.Driver.Env (hsc_units) +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic + +import GHC.Rename.Unbound + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Env( tcInitTidyEnv ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify ( checkTyVarEq ) +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.EvTerm +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) + +import GHC.Types.Name +import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual + , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error +import qualified GHC.Types.Unique.Map as UM + +--import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) +import GHC.Unit.Module +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCo.Ppr ( pprTyVars + ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.DataCon + +import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) +import GHC.Utils.Misc +import GHC.Utils.Outputable as O +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.FV ( fvVarList, unionFV ) + +import GHC.Data.Bag +import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) +import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict + +import Control.Monad ( unless, when, foldM, forM_ ) +import Data.Foldable ( toList ) +import Data.Functor ( (<&>) ) +import Data.Function ( on ) +import Data.List ( partition, mapAccumL, sort ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import qualified Data.List.NonEmpty as NE ( map, reverse ) +import Data.List ( sortBy ) +import Data.Ord ( comparing ) +import GHC.Tc.Errors.Ppr + + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +-- | Report unsolved goals as errors or warnings. We may also turn some into +-- deferred run-time errors if `-fdefer-type-errors` is on. +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; let type_errors | not defer_errors = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors + + ; defer_holes <- goptM Opt_DeferTypedHoles + ; let expr_holes | not defer_holes = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnTypedHoles + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables + ; let out_of_scope_holes | not defer_out_of_scope + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables + + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted + + ; ev_binds <- getTcEvBindsMap binds_var + ; return (evBindMapBinds ev_binds)} + +-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on +-- However, do not make any evidence bindings, because we don't +-- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. +-- See Note [Deferring coercion errors to runtime] +-- Used by solveEqualities for kind equalities +-- (see Note [Fail fast on kind errors] in "GHC.Tc.Solver") +reportAllUnsolved :: WantedConstraints -> TcM () +reportAllUnsolved wanted + = do { ev_binds <- newNoTcEvBinds + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; report_unsolved ErrorWithoutFlag + ErrorWithoutFlag type_holes ErrorWithoutFlag + ev_binds wanted } + +-- | Report all unsolved goals as warnings (but without deferring any errors to +-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in +-- "GHC.Tc.Solver" +warnAllUnsolved :: WantedConstraints -> TcM () +warnAllUnsolved wanted + = do { ev_binds <- newTcEvBinds + ; report_unsolved WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + ev_binds wanted } + +-- | Report unsolved goals as errors or warnings. +report_unsolved :: DiagnosticReason -- Deferred type errors + -> DiagnosticReason -- Expression holes + -> DiagnosticReason -- Type holes + -> DiagnosticReason -- Out of scope holes + -> EvBindsVar -- cec_binds + -> WantedConstraints -> TcM () +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] + ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) + + ; wanted <- zonkWC wanted -- Zonk to reveal all information + + ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs + free_tvs = filterOut isCoVar $ + tyCoVarsOfWCList wanted + -- tyCoVarsOfWC returns free coercion *holes*, even though + -- they are "bound" by other wanted constraints. They in + -- turn may mention variables bound further in, which makes + -- no sense. Really we should not return those holes at all; + -- for now we just filter them out. + + ; traceTc "reportUnsolved (after zonking):" $ + vcat [ text "Free tyvars:" <+> pprTyVars free_tvs + , text "Tidy env:" <+> ppr tidy_env + , text "Wanted:" <+> ppr wanted ] + + ; warn_redundant <- woptM Opt_WarnRedundantConstraints + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes + , cec_out_of_scope_holes = out_of_scope_holes + , cec_suppress = insolubleWC wanted + -- See Note [Suppressing error messages] + -- Suppress low-priority errors if there + -- are insoluble errors anywhere; + -- See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus + , cec_warn_redundant = warn_redundant + , cec_expand_syns = exp_syns + , cec_binds = binds_var } + + ; tc_lvl <- getTcLevel + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +-- | Make a report from a single 'TcReportMsg'. +important :: ReportErrCtxt -> TcReportMsg -> SolverReport +important ctxt doc = mempty { sr_important_msgs = [ReportWithCtxt ctxt doc] } + +mk_relevant_bindings :: RelevantBindings -> SolverReport +mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } + +mk_report_hints :: [GhcHint] -> SolverReport +mk_report_hints hints = mempty { sr_hints = hints } + +-- | Returns True <=> the ReportErrCtxt indicates that something is deferred +deferringAnyBindings :: ReportErrCtxt -> Bool + -- Don't check cec_type_holes, as these don't cause bindings to be deferred +deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag }) = False +deferringAnyBindings _ = True + +maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt +-- Switch off defer-type-errors inside CoEvBindsVar +-- See Note [Failing equalities with no evidence bindings] +maybeSwitchOffDefer evb ctxt + | CoEvBindsVar{} <- evb + = ctxt { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag } + | otherwise + = ctxt + +{- Note [Failing equalities with no evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we go inside an implication that has no term evidence +(e.g. unifying under a forall), we can't defer type errors. You could +imagine using the /enclosing/ bindings (in cec_binds), but that may +not have enough stuff in scope for the bindings to be well typed. So +we just switch off deferred type errors altogether. See #14605. + +This is done by maybeSwitchOffDefer. It's also useful in one other +place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. + +Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors". Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. + +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the simple constraints here. Sometimes the + simple-constraint errors are a knock-on effect of the insolubles. + +This suppression behaviour is controlled by the Bool flag in +ReportErrorSpec, as used in reportWanteds. + +But we need to take care: flags can turn errors into warnings, and we +don't want those warnings to suppress subsequent errors (including +suppressing the essential addTcEvBind for them: #15152). So in +tryReporter we use askNoErrs to see if any error messages were +/actually/ produced; if not, we don't switch on suppression. + +A consequence is that warnings never suppress warnings, so turning an +error into a warning may allow subsequent warnings to appear that were +previously suppressed. (e.g. partial-sigs/should_fail/T14584) +-} + +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs + , ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_status = status, ic_info = info + , ic_env = tcl_env + , ic_tclvl = tc_lvl }) + | BracketSkol <- info + , not insoluble + = return () -- For Template Haskell brackets report only + -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise + = do { traceTc "reportImplic" $ vcat + [ text "tidy env:" <+> ppr (cec_tidy ctxt) + , text "skols: " <+> pprTyVars tvs + , text "tidy skols:" <+> pprTyVars tvs' ] + + ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs + -- Do /not/ use the tidied tvs because then are in the + -- wrong order, so tidying will rename things wrongly + ; reportWanteds ctxt' tc_lvl wanted + ; when (cec_warn_redundant ctxt) $ + warnRedundantConstraints ctxt' tcl_env info' dead_givens } + where + insoluble = isInsolubleStatus status + (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $ + scopedSort tvs + -- scopedSort: the ic_skols may not be in dependency order + -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint) + -- but tidying goes wrong on out-of-order constraints; + -- so we sort them here before tidying + info' = tidySkolemInfoAnon env1 info + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_info = info' } + + ctxt1 = maybeSwitchOffDefer evb ctxt + ctxt' = ctxt1 { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + + , cec_suppress = insoluble || cec_suppress ctxt + -- Suppress inessential errors if there + -- are insolubles anywhere in the + -- tree rooted here, or we've come across + -- a suppress-worthy constraint higher up (#11541) + + , cec_binds = evb } + + dead_givens = case status of + IC_Solved { ics_dead = dead } -> dead + _ -> [] + + bad_telescope = case status of + IC_BadTelescope -> True + _ -> False + +warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () +-- See Note [Tracking redundant constraints] in GHC.Tc.Solver +warnRedundantConstraints ctxt env info ev_vars + | null redundant_evs + = return () + + | SigSkol user_ctxt _ _ <- info + = setLclEnv env $ -- We want to add "In the type signature for f" + -- to the error context, which is a bit tiresome + setSrcSpan (redundantConstraintsSpan user_ctxt) $ + report_redundant_msg True + + | otherwise -- But for InstSkol there already *is* a surrounding + -- "In the instance declaration for Eq [a]" context + -- and we don't want to say it twice. Seems a bit ad-hoc + = report_redundant_msg False + where + report_redundant_msg :: Bool -- ^ whether to add "In ..." to the diagnostic + -> TcRn () + report_redundant_msg show_info + = do { lcl_env <- getLclEnv + ; msg <- + mkErrorReport + lcl_env + (TcRnRedundantConstraints redundant_evs (info, show_info)) + (Just ctxt) + [] + ; reportDiagnostic msg } + + redundant_evs = + filterOut is_type_error $ + case info of -- See Note [Redundant constraints in instance decls] + InstSkol -> filterOut (improving . idType) ev_vars + _ -> ev_vars + + -- See #15232 + is_type_error = isJust . userTypeError_maybe . idType + + improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () +reportBadTelescope ctxt env (ForAllSkol telescope) skols + = do { msg <- mkErrorReport + env + (TcRnSolverReport [report] ErrorWithoutFlag noHints) + (Just ctxt) + [] + ; reportDiagnostic msg } + where + report = ReportWithCtxt ctxt $ BadTelescope telescope skols + +reportBadTelescope _ _ skol_info skols + = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For instance declarations, we don't report unused givens if +they can give rise to improvement. Example (#10100): + class Add a b ab | a b -> ab, a ab -> b + instance Add Zero b b + instance Add a b ab => Add (Succ a) b (Succ ab) +The context (Add a b ab) for the instance is clearly unused in terms +of evidence, since the dictionary has no fields. But it is still +needed! With the context, a wanted constraint + Add (Succ Zero) beta (Succ Zero) +we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. +But without the context we won't find beta := Zero. + +This only matters in instance declarations.. +-} + +reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () +reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics + , wc_holes = holes }) + = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_holes = " <+> ppr tidy_holes ]) + + -- First, deal with any out-of-scope errors: + ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes + -- don't suppress out-of-scope errors + ctxt_for_scope_errs = ctxt { cec_suppress = False } + ; (_, no_out_of_scope) <- askNoErrs $ + reportHoles tidy_cts ctxt_for_scope_errs out_of_scope + + -- Next, deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + -- These /ones/ are not suppressed by the incoming context + -- (but will be by out-of-scope errors) + ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } + ; reportHoles tidy_cts ctxt_for_insols other_holes + -- holes never suppress + + ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts + + -- Now all the other constraints. We suppress errors here if + -- any of the first batch failed, or if the enclosing context + -- says to suppress + ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } + ; (_, leftovers) <- tryReporters ctxt2 report2 cts1 + ; massertPpr (null leftovers) + (text "The following unsolved Wanted constraints \ + \have not been reported to the user:" + $$ ppr leftovers) + + -- All the Derived ones have been filtered out of simples + -- by the constraint solver. This is ok; we don't want + -- to report unsolved Derived goals as errors + -- See Note [Do not report derived but soluble errors] + + ; mapBagM_ (reportImplic ctxt2) implics } + -- NB ctxt2: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a *given* insoluble here (= inaccessible code) + where + env = cec_tidy ctxt + tidy_cts = bagToList (mapBag (tidyCt env) simples) + tidy_holes = bagToList (mapBag (tidyHole env) holes) + + -- report1: ones that should *not* be suppressed by + -- an insoluble somewhere else in the tree + -- It's crucial that anything that is considered insoluble + -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise + -- we might suppress its error message, and proceed on past + -- type checking to get a Lint error later + report1 = [ ("custom_error", unblocked is_user_type_error, True, mkUserTypeErrorReporter) + + , given_eq_spec + , ("insoluble2", unblocked utterly_wrong, True, mkGroupReporter mkEqErr) + , ("skolem eq1", unblocked very_wrong, True, mkSkolReporter) + , ("skolem eq2", unblocked skolem_eq, True, mkSkolReporter) + , ("non-tv eq", unblocked non_tv_eq, True, mkSkolReporter) + + -- The only remaining equalities are alpha ~ ty, + -- where alpha is untouchable; and representational equalities + -- Prefer homogeneous equalities over hetero, because the + -- former might be holding up the latter. + -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical + , ("Homo eqs", unblocked is_homo_equality, True, mkGroupReporter mkEqErr) + , ("Other eqs", unblocked is_equality, True, mkGroupReporter mkEqErr) + , ("Blocked eqs", is_equality, False, mkSuppressReporter mkBlockedEqErr)] + + -- report2: we suppress these if there are insolubles elsewhere in the tree + report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) + , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + , ("FixedRuntimeRep", is_FRR, False, mkGroupReporter mkFRRErr) + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] + + -- also checks to make sure the constraint isn't HoleBlockerReason + -- See TcCanonical Note [Equalities with incompatible kinds], (4) + unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool + unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False + unblocked checker ct pred = checker ct pred + + -- rigid_nom_eq, rigid_nom_tv_eq, + is_dict, is_equality, is_ip, is_FRR, is_irred :: Ct -> Pred -> Bool + + is_given_eq ct pred + | EqPred {} <- pred = arisesFromGivens ct + | otherwise = False + -- I think all given residuals are equalities + + -- Things like (Int ~N Bool) + utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 + utterly_wrong _ _ = False + + -- Things like (a ~N Int) + very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 + very_wrong _ _ = False + + -- Things like (a ~N b) or (a ~N F Bool) + skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 + skolem_eq _ _ = False + + -- Things like (F a ~N Int) + non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) + non_tv_eq _ _ = False + + is_user_type_error ct _ = isUserTypeErrorCt ct + + is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 + is_homo_equality _ _ = False + + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_FRR ct (SpecialPred ConcretePrimPred _) + | FixedRuntimeRepOrigin {} <- ctOrigin ct + = True + is_FRR _ _ + = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + given_eq_spec -- See Note [Given errors] + | has_gadt_match (cec_encl ctxt) + = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) + | otherwise + = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) + -- False means don't suppress subsequent errors + -- Reason: we don't report all given errors + -- (see mkGivenErrorReporter), and we should only suppress + -- subsequent errors if we actually report this one! + -- #13446 is an example + + -- See Note [Given errors] + has_gadt_match [] = False + has_gadt_match (implic : implics) + | PatSkol {} <- ic_info implic + , ic_given_eqs implic /= NoGivenEqs + , ic_warn_inaccessible implic + -- Don't bother doing this if -Winaccessible-code isn't enabled. + -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. + = True + | otherwise + = has_gadt_match implics + +--------------- +isSkolemTy :: TcLevel -> Type -> Bool +-- The type is a skolem tyvar +isSkolemTy tc_lvl ty + | Just tv <- getTyVar_maybe ty + = isSkolemTyVar tv + || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) + -- The last case is for touchable TyVarTvs + -- we postpone untouchables to a latter test (too obscure) + + | otherwise + = False + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isTypeFamilyTyCon tc -> Just tc + _ -> Nothing + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = ReportErrCtxt -> [Ct] -> TcM () +type ReporterSpec + = ( String -- Name + , Ct -> Pred -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself + +mkSkolReporter :: Reporter +-- Suppress duplicates with either the same LHS, or same location +mkSkolReporter ctxt cts + = mapM_ (reportGroup mkEqErr ctxt) (group cts) + where + group [] = [] + group (ct:cts) = (ct : yeses) : group noes + where + (yeses, noes) = partition (group_with ct) cts + + group_with ct1 ct2 + | EQ <- cmp_loc ct1 ct2 = True + | eq_lhs_type ct1 ct2 = True + | otherwise = False + +reportHoles :: [Ct] -- other (tidied) constraints + -> ReportErrCtxt -> [Hole] -> TcM () +reportHoles tidy_cts ctxt holes + = do + diag_opts <- initDiagOpts <$> getDynFlags + let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) + holes' = filter (keepThisHole severity) holes + -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` + -- because otherwise types will be zonked and tidied many times over. + (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') + let ctxt' = ctxt { cec_tidy = tidy_env' } + forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole + ; reportDiagnostic msg } + +keepThisHole :: Severity -> Hole -> Bool +-- See Note [Skip type holes rapidly] +keepThisHole sev hole + = case hole_sort hole of + ExprHole {} -> True + TypeHole -> keep_type_hole + ConstraintHole -> keep_type_hole + where + keep_type_hole = case sev of + SevIgnore -> False + _ -> True + +-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole. +-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied +-- type for each Id in any of the binder stacks in the 'TcLclEnv's. +-- Since there is a huge overlap between these stacks, is is much, +-- much faster to do them all at once, avoiding duplication. +zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type) +zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls) + where + go envs tc_bndr = case tc_bndr of + TcTvBndr {} -> return envs + TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs + TcIdBndr_ExpType name et _top_lvl -> + do { mb_ty <- readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just ty -> go_one name ty envs + Nothing -> return envs + } + go_one name ty (tidy_env, name_env) = do + if name `elemNameEnv` name_env + then return (tidy_env, name_env) + else do + (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty + return (tidy_env', extendNameEnv name_env name tidy_ty) + +{- Note [Skip type holes rapidly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have module with a /lot/ of partial type signatures, and we +compile it while suppressing partial-type-signature warnings. Then +we don't want to spend ages constructing error messages and lists of +relevant bindings that we never display! This happened in #14766, in +which partial type signatures in a Happy-generated parser cause a huge +increase in compile time. + +The function ignoreThisHole short-circuits the error/warning generation +machinery, in cases where it is definitely going to be a no-op. +-} + +mkUserTypeErrorReporter :: Reporter +mkUserTypeErrorReporter ctxt + = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct + ; maybeReportError ctxt ct err + ; addDeferredBinding ctxt err ct } + +mkUserTypeError :: Ct -> TcReportMsg +mkUserTypeError ct = + case getUserTypeErrorMsg ct of + Just msg -> UserTypeError msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) + +mkGivenErrorReporter :: Reporter +-- See Note [Given errors] +mkGivenErrorReporter ctxt cts + = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct + ; let (implic:_) = cec_encl ctxt + -- Always non-empty when mkGivenErrorReporter is called + ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the immediately-enclosing implication. + -- See Note [Inaccessible code] + + ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2 + -- The hints wouldn't help in this situation, so we discard them. + ; let supplementary = [ SupplementaryBindings relevant_binds ] + msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (ReportWithCtxt ctxt) $ eq_err_msgs) + ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary + ; reportDiagnostic msg } + where + (ct : _ ) = cts -- Never empty + (ty1, ty2) = getEqPredTys (ctPred ct) + +ignoreErrorReporter :: Reporter +-- Discard Given errors that don't come from +-- a pattern match; maybe we should warn instead? +ignoreErrorReporter ctxt cts + = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt)) + ; return () } + + +{- Note [Given errors] +~~~~~~~~~~~~~~~~~~~~~~ +Given constraints represent things for which we have (or will have) +evidence, so they aren't errors. But if a Given constraint is +insoluble, this code is inaccessible, and we might want to at least +warn about that. A classic case is + + data T a where + T1 :: T Int + T2 :: T a + T3 :: T Bool + + f :: T Int -> Bool + f T1 = ... + f T2 = ... + f T3 = ... -- We want to report this case as inaccessible + +We'd like to point out that the T3 match is inaccessible. It +will have a Given constraint [G] Int ~ Bool. + +But we don't want to report ALL insoluble Given constraints. See Trac +#12466 for a long discussion. For example, if we aren't careful +we'll complain about + f :: ((Int ~ Bool) => a -> a) -> Int +which arguably is OK. It's more debatable for + g :: (Int ~ Bool) => Int -> Int +but it's tricky to distinguish these cases so we don't report +either. + +The bottom line is this: has_gadt_match looks for an enclosing +pattern match which binds some equality constraints. If we +find one, we report the insoluble Given. +-} + +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints +-- Group together errors from same location, +-- and report only the first (to avoid a cascade) +mkGroupReporter mk_err ctxt cts + = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +-- Like mkGroupReporter, but doesn't actually print error messages +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) + -> Reporter +mkSuppressReporter mk_err ctxt cts + = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) + +eq_lhs_type :: Ct -> Ct -> Bool +eq_lhs_type ct1 ct2 + = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of + (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> + (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) + _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) + +cmp_loc :: Ct -> Ct -> Ordering +cmp_loc ct1 ct2 = get ct1 `compare` get ct2 + where + get ct = realSrcSpanStart (ctLocSpan (ctLoc ct)) + -- Reduce duplication by reporting only one error from each + -- /starting/ location even if the end location differs + +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter +reportGroup mk_err ctxt cts + | ct1 : _ <- cts = + do { err <- mk_err ctxt cts + ; traceTc "About to maybeReportErr" $ + vcat [ text "Constraint:" <+> ppr cts + , text "cec_suppress =" <+> ppr (cec_suppress ctxt) + , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt ct1 err + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + -- Add deferred bindings for all + -- Redundant if we are going to abort compilation, + -- but that's hard to know for sure, and if we don't + -- abort, we need bindings for all (e.g. #12156) + | otherwise = panic "empty reportGroup" + +-- like reportGroup, but does not actually report messages. It still adds +-- -fdefer-type-errors bindings, though. +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter +suppressGroup mk_err ctxt cts + = do { err <- mk_err ctxt cts + ; traceTc "Suppressing errors for" (ppr cts) + ; mapM_ (addDeferredBinding ctxt err) cts } + +-- See Note [No deferring for multiplicity errors] +nonDeferrableOrigin :: CtOrigin -> Bool +nonDeferrableOrigin NonLinearPatternOrigin = True +nonDeferrableOrigin (UsageEnvironmentOf {}) = True +nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True +nonDeferrableOrigin _ = False + +maybeReportError :: ReportErrCtxt -> Ct -> SolverReport -> TcM () +maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints }) + = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic + do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag + | otherwise = cec_defer_type_errors ctxt + -- See Note [No deferring for multiplicity errors] + diag = TcRnSolverReport important reason hints + msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp + reportDiagnostic msg + +addDeferredBinding :: ReportErrCtxt -> SolverReport -> Ct -> TcM () +-- See Note [Deferring coercion errors to runtime] +addDeferredBinding ctxt err ct + | deferringAnyBindings ctxt + , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct + -- Only add deferred bindings for Wanted constraints + = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err + ; let ev_binds_var = cec_binds ctxt + + ; case dest of + EvVarDest evar + -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm + HoleDest hole + -> do { -- See Note [Deferred errors for coercion holes] + let co_var = coHoleCoVar hole + ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm + ; fillCoercionHole hole (mkTcCoVarCo co_var) }} + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term + -> SolverReport -> TcM EvTerm +mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) + = do { msg <- mkErrorReport + (ctLocEnv ct_loc) + (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp + -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" + ; dflags <- getDynFlags + ; let err_msg = pprLocMsgEnvelope msg + err_str = showSDoc dflags $ + err_msg $$ text "(deferred type error)" + + ; return $ evDelayedError ty err_str } + +tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +-- Use the first reporter in the list whose predicate says True +tryReporters ctxt reporters cts + = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts + ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts) + ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts + ; traceTc "tryReporters }" (ppr cts') + ; return (ctxt', cts') } + where + go ctxt [] vis_cts invis_cts + = return (ctxt, vis_cts ++ invis_cts) + + go ctxt (r : rs) vis_cts invis_cts + -- always look at *visible* Origins before invisible ones + -- this is the whole point of isVisibleOrigin + = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts + ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts + ; go ctxt'' rs vis_cts' invis_cts' } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have -fdefer-type-errors + -- But suppress their error messages + +tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) cts + | null yeses + = return (ctxt, cts) + | otherwise + = do { traceTc "tryReporter{ " (text str <+> ppr yeses) + ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) + ; let suppress_now = not no_errs && suppress_after + -- See Note [Suppressing error messages] + ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } + ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) + ; return (ctxt', nos) } + where + (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts + +-- | Wrap an input 'TcRnMessage' with additional contextual information, +-- such as relevant bindings or valid hole fits. +mkErrorReport :: TcLclEnv + -> TcRnMessage + -- ^ The main payload of the message. + -> Maybe ReportErrCtxt + -- ^ The context to add, after the main diagnostic + -- but before the supplementary information. + -- Nothing <=> don't add any context. + -> [SolverReportSupplementary] + -- ^ Supplementary information, to be added at the end of the message. + -> TcM (MsgEnvelope TcRnMessage) +mkErrorReport tcl_env msg mb_ctxt supplementary + = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt + ; unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let + err_info = + ErrInfo + (fromMaybe empty mb_context) + (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) + ; mkTcRnMessage + (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } + +-- | Pretty-print supplementary information, to add to an error report. +pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprSolverReportSupplementary hfdc = \case + SupplementaryBindings binds -> pprRelevantBindings binds + SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits + SupplementaryCts cts -> pprConstraintsInclude cts + +-- | Display a collection of valid hole fits. +pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs)) + = fits_msg $$ refs_msg + + where + fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc + fits_msg = ppUnless (null fits) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) fits) + $$ ppWhen discarded_fits fits_discard_msg + refs_msg = ppUnless (null refs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) refs) + $$ ppWhen discarded_refs refs_discard_msg + fits_discard_msg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + refs_discard_msg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + +-- | Add a "Constraints include..." message. +-- +-- See Note [Constraints include ...] +pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprConstraintsInclude cts + = ppUnless (null cts) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint cts) + where + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + +{- Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! + +With #10283, you can now opt out of deferred type error warnings. + +Note [No deferring for multiplicity errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify, +linear types do not support casts and any nontrivial coercion will raise +an error during desugaring. + +This means that even if we defer a multiplicity mismatch during typechecking, +the desugarer will refuse to compile anyway. Worse: the error raised +by the desugarer would shadow the type mismatch warnings (#20083). +As a solution, we refuse to defer submultiplicity constraints. Test: T20083. + +To determine whether a constraint arose from a submultiplicity check, we +look at the CtOrigin. All calls to tcSubMult use one of two origins, +UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not +used outside of linear types. + +In the future, we should compile 'WpMultCoercion' to a runtime error with +-fdefer-type-errors, but the current implementation does not always +place the wrapper in the right place and the resulting program can fail Lint. +This plan is tracked in #20083. + +Note [Deferred errors for coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need to defer a type error where the destination for the evidence +is a coercion hole. We can't just put the error in the hole, because we can't +make an erroneous coercion. (Remember that coercions are erased for runtime.) +Instead, we invent a new EvVar, bind it to an error and then make a coercion +from that EvVar, filling the hole with that coercion. Because coercions' +types are unlifted, the error is guaranteed to be hit before we get to the +coercion. + +Note [Do not report derived but soluble errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wc_simples include Derived constraints that have not been solved, +but are not insoluble (in that case they'd be reported by 'report1'). +We do not want to report these as errors: + +* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have + an unsolved [D] Eq a, and we do not want to report that; it's just noise. + +* Functional dependencies. For givens, consider + class C a b | a -> b + data T a where + MkT :: C a d => [d] -> T a + f :: C a b => T a -> F Int + f (MkT xs) = length xs + Then we get a [D] b~d. But there *is* a legitimate call to + f, namely f (MkT [True]) :: T Bool, in which b=d. So we should + not reject the program. + + For wanteds, something similar + data T a where + MkT :: C Int b => a -> b -> T a + g :: C Int c => c -> () + f :: T a -> () + f (MkT x y) = g x + Here we get [G] C Int b, [W] C Int a, hence [D] a~b. + But again f (MkT True True) is a legitimate call. + +(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose +derived superclasses between iterations of the solver.) + +For functional dependencies, here is a real example, +stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs + + class C a b | a -> b + g :: C a b => a -> b -> () + f :: C a b => a -> b -> () + f xa xb = + let loop = g xa + in loop xb + +We will first try to infer a type for loop, and we will succeed: + C a b' => b' -> () +Subsequently, we will type check (loop xb) and all is good. But, +recall that we have to solve a final implication constraint: + C a b => (C a b' => .... cts from body of loop .... )) +And now we have a problem as we will generate an equality b ~ b' and fail to +solve it. + + +************************************************************************ +* * + Irreducible predicate errors +* * +************************************************************************ +-} + +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkIrredErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let msg = important ctxt $ + CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing + ; return $ msg `mappend` mk_relevant_bindings binds_msg } + where + ct1:others = cts + +{- Note [Constructing Hole Errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms, +these "hole" errors are /not/ suppressed by cec_suppress. We want to see them! + +There are two cases to consider: + +1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on, + in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning + only if -Wout-of-scope-variables is on. + +2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated + for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case + the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on. + +The above can be summarised into the following table: + +| Hole Type | Active Flags | Outcome | +|--------------|----------------------------------------------------------|------------------| +| out-of-scope | None | Error | +| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning | +| out-of-scope | -fdefer-out-of-scope-variables | Ignore (discard) | +| type | None | Error | +| type | -XPartialTypeSignatures, -Wpartial-type-signatures | Warning | +| type | -XPartialTypeSignatures | Ignore (discard) | +| expression | None | Error | +| expression | -Wdefer-typed-holes, -Wtyped-holes | Warning | +| expression | -Wdefer-typed-holes | Ignore (discard) | + +See also 'reportUnsolved'. + +-} + +---------------- +-- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. +mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) +mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) + | isOutOfScopeHole hole + = do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; let (imp_errs, hints) + = unknownNameSuggestions WL_Anything + dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ) + errs = [ReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] + report = SolverReport errs [] hints + + ; maybeAddDeferredBindings ctxt hole report + ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing [] + -- Pass the value 'Nothing' for the context, as it's generally not helpful + -- to include the context here. + } + where + lcl_env = ctLocEnv ct_loc + + -- general case: not an out-of-scope error +mkHoleError lcl_name_cache tidy_simples ctxt + hole@(Hole { hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { rel_binds + <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) + -- The 'False' means "don't filter the bindings"; see Trac #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let relevant_cts + | ExprHole _ <- sort, show_hole_constraints + = givenConstraints ctxt + | otherwise + = [] + + ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits + ; (ctxt, hole_fits) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, noValidHoleFits) + ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty + ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt + | otherwise = cec_type_holes ctxt + errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] + supp = [ SupplementaryBindings rel_binds + , SupplementaryCts relevant_cts + , SupplementaryHoleFits hole_fits ] + + ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp []) + + ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp + } + + where + lcl_env = ctLocEnv ct_loc + +-- | For all the skolem type variables in a type, zonk the skolem info and group together +-- all the type variables with the same origin. +zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) +zonkAndGroupSkolTvs hole_ty = do + zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list + return (zonked_info, other_tvs) + where + tvs = tyCoVarsOfTypeList hole_ty + (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs + + group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)]) + group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] + + skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems) + +{- Note [Adding deferred bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When working with typed holes we have to deal with the case where +we want holes to be reported as warnings to users during compile time but +as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings' +so that the correct 'Severity' can be computed out of that later on. + +-} + + +-- | Adds deferred bindings (as errors). +-- See Note [Adding deferred bindings]. +maybeAddDeferredBindings :: ReportErrCtxt + -> Hole + -> SolverReport + -> TcM () +maybeAddDeferredBindings ctxt hole report = do + case hole_sort hole of + ExprHole (HER ref ref_ty _) -> do + -- Only add bindings for holes in expressions + -- not for holes in partial type signatures + -- cf. addDeferredBinding + when (deferringAnyBindings ctxt) $ do + err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report + -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. + -- See Note [Holes] in GHC.Tc.Types.Constraint + writeMutVar ref err_tm + _ -> pure () + +-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module +-- imports +validHoleFits :: ReportErrCtxt -- ^ The context we're in, i.e. the + -- implications and the tidy environment + -> [Ct] -- ^ Unsolved simple constraints + -> Hole -- ^ The hole + -> TcM (ReportErrCtxt, ValidHoleFits) + -- ^ We return the new context + -- with a possibly updated + -- tidy environment, and + -- the valid hole fits. +validHoleFits ctxt@(CEC {cec_encl = implics + , cec_tidy = lcl_env}) simps hole + = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole + ; return (ctxt {cec_tidy = tidy_env}, fits) } + +-- See Note [Constraints include ...] +givenConstraints :: ReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints ctxt + = do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc (ic_env implic)) } + +---------------- + +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkIPErr ctxt cts + = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 + ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others) + ; return $ msg `mappend` mk_relevant_bindings binds_msg } + where + ct1:others = cts + +---------------- + +-- | Create a user-facing error message for unsolved @'Concrete#' ki@ +-- Wanted constraints arising from representation-polymorphism checks. +-- +-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. +mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkFRRErr ctxt cts + = do { -- Zonking/tidying. + ; origs <- + -- Zonk/tidy the 'CtOrigin's. + zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) + <&> + -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. + (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) + -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), + -- with the corresponding types: + -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... + ; let origs_and_tys = map frr_orig_and_type origs + + ; return $ important ctxt $ FixedRuntimeRepError origs_and_tys } + where + + frr_orig_and_type :: CtOrigin -> (FRROrigin, Type) + frr_orig_and_type (FixedRuntimeRepOrigin ty frr_orig) = (frr_orig, ty) + frr_orig_and_type orig + = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" + (text "origin =" <+> ppr orig) + +{- +Note [Constraints include ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'givenConstraintsMsg' returns the "Constraints include ..." message enabled by +-fshow-hole-constraints. For example, the following hole: + + foo :: (Eq a, Show a) => a -> String + foo x = _ + +would generate the message: + + Constraints include + Eq a (from foo.hs:1:1-36) + Show a (from foo.hs:1:1-36) + +Constraints are displayed in order from innermost (closest to the hole) to +outermost. There's currently no filtering or elimination of duplicates. + +************************************************************************ +* * + Equality errors +* * +************************************************************************ + +Note [Inaccessible code] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + T1 :: T a + T2 :: T Bool + + f :: (a ~ Int) => T a -> Int + f T1 = 3 + f T2 = 4 -- Unreachable code + +Here the second equation is unreachable. The original constraint +(a~Int) from the signature gets rewritten by the pattern-match to +(Bool~Int), so the danger is that we report the error as coming from +the *signature* (#7293). So, for Given errors we replace the +env (and hence src-loc) on its CtLoc with that from the immediately +enclosing implication. + +Note [Error messages for untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#9109) + data G a where { GBool :: G Bool } + foo x = case x of GBool -> True + +Here we can't solve (t ~ Bool), where t is the untouchable result +meta-var 't', because of the (a ~ Bool) from the pattern match. +So we infer the type + f :: forall a t. G a -> t +making the meta-var 't' into a skolem. So when we come to report +the unsolved (t ~ Bool), t won't look like an untouchable meta-var +any more. So we don't assert that it is. +-} + +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM SolverReport +mkEqErr1 ctxt ct -- Wanted or derived; + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + ; rdr_env <- getGlobalRdrEnv + ; fam_envs <- tcGetFamInstEnvs + ; let mb_coercible_msg = case ctEqRel ct of + NomEq -> Nothing + ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) + ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2 + ; let + report = foldMap (important ctxt) (reverse prev_msgs) + `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg) + `mappend` (mk_relevant_bindings binds_msg) + `mappend` (mk_report_hints hints) + ; return report } + where + (ty1, ty2) = getEqPredTys (ctPred ct) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> Maybe CoercibleMsg +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = Just $ UnknownRoles s1 + | otherwise + = Nothing + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ TyConIsAbstract tc + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , isNothing (lookupGRE_Name rdr_env dc_name) + = Just $ OutOfScopeNewtypeConstructor tc data_con + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +-- | Accumulated messages in reverse order. +type AccReportMsgs = NonEmpty TcReportMsg + +mkEqErr_help :: ReportErrCtxt + -> Ct + -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) +mkEqErr_help ctxt ct ty1 ty2 + | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 + = mkTyVarEqErr ctxt ct tv1 ty2 + | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 + = mkTyVarEqErr ctxt ct tv2 ty1 + | otherwise + = return (reportEqErr ctxt ct ty1 ty2 :| [], []) + +reportEqErr :: ReportErrCtxt + -> Ct + -> TcType -> TcType -> TcReportMsg +reportEqErr ctxt ct ty1 ty2 + = mkTcReportWithInfo mismatch eqInfos + where + mismatch = misMatchOrCND False ctxt ct ty1 ty2 + eqInfos = eqInfoMsgs ct ty1 ty2 + +mkTyVarEqErr :: ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) +-- tv1 and ty2 are already tidied +mkTyVarEqErr ctxt ct tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) + ; dflags <- getDynFlags + ; mkTyVarEqErr' dflags ctxt ct tv1 ty2 } + +mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) +mkTyVarEqErr' dflags ctxt ct tv1 ty2 + -- impredicativity is a simple error to understand; try it first + | check_eq_result `cterHasProblem` cteImpredicative = do + tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 + let + poly_msg = CannotUnifyWithPolytype ct tv1 ty2 + poly_msg_with_info + | isSkolemTyVar tv1 + = mkTcReportWithInfo poly_msg tyvar_eq_info + | otherwise + = poly_msg + -- Unlike the other reports, this discards the old 'report_important' + -- instead of augmenting it. This is because the details are not likely + -- to be helpful since this is just an unimplemented feature. + return (poly_msg_with_info <| headline_msg :| [], []) + + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have + -- swapped in Solver.Canonical.canEqTyVarHomo + || isTyVarTyVar tv1 && not (isTyVarTy ty2) + || ctEqRel ct == ReprEq + -- The cases below don't really apply to ReprEq (except occurs check) + = do + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) + + | cterHasOccursCheck check_eq_result + -- We report an "occurs check" even for a ~ F t a, where F is a type + -- function; it's not insoluble (because in principle F could reduce) + -- but we have certainly been unable to solve it + = let extras2 = eqInfoMsgs ct ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + + extras3 = case interesting_tyvars of + [] -> [] + (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] + + in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + + -- If the immediately-enclosing implication has 'tv' a skolem, and + -- we know by now its an InferSkol kind of skolem, then presumably + -- it started life as a TyVarTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = do + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_skols = skols } <- implic + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols + , not (null esc_skols) + = return (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) + + -- Nastiest case: attempt to unify an untouchable variable + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a TyVarTv, else it'd have been unified + -- See Note [Error messages for untouchables] + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_tclvl = lvl } <- implic + = assertPpr (not (isTouchableMetaTyVar lvl tv1)) + (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] + let tclvl_extra = UntouchableVariable tv1 implic + tv_extra <- extraTyVarEqInfo tv1 ty2 + return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) + + | otherwise + = return (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) + -- This *can* happen (#6123) + -- Consider an ambiguous top-level constraint (a ~ F a) + -- Not an occurs check, because F is a type function. + where + headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + mismatch_msg = mkMismatchMsg ct ty1 ty2 + add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 + + ty1 = mkTyVarTy tv1 + + check_eq_result = case ct of + CIrredCan { cc_reason = NonCanonicalReason result } -> result + CIrredCan { cc_reason = HoleBlockerReason {} } -> cteProblem cteHoleBlocker + _ -> checkTyVarEq dflags tv1 ty2 + -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type + -- variable is on the right, so we don't get useful info for the CIrredCan, + -- and have to compute the result of checkTyVarEq here. + + insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs + +eqInfoMsgs :: Ct -> TcType -> TcType -> [TcReportInfo] +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +eqInfoMsgs ct ty1 ty2 + = catMaybes [tyfun_msg, ambig_msg] + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct + + ambig_msg | isJust mb_fun1 || isJust mb_fun2 + , not (null ambig_kvs && null ambig_tvs) + = Just $ Ambiguity False (ambig_kvs, ambig_tvs) + | otherwise + = Nothing + + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + , not (isInjectiveTyCon tc1 Nominal) + = Just $ NonInjectiveTyFam tc1 + | otherwise + = Nothing + +misMatchOrCND :: Bool -> ReportErrCtxt -> Ct + -> TcType -> TcType -> TcReportMsg +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + | insoluble_occurs_check -- See Note [Insoluble occurs check] + || (isRigidTy ty1 && isRigidTy ty2) + || isGivenCt ct + || null givens + = -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + mkMismatchMsg ct ty1 ty2 + + | otherwise + = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2) + + where + ev = ctEvidence ct + level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel + givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] + -- Keep only UserGivens that have some equalities. + -- See Note [Suppress redundant givens during error reporting] + +-- These are for the "blocked" equalities, as described in TcCanonical +-- Note [Equalities with incompatible kinds], wrinkle (2). There should +-- always be another unsolved wanted around, which will ordinarily suppress +-- this message. But this can still be printed out with -fdefer-type-errors +-- (sigh), so we must produce a message. +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct) +mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" + +{- +Note [Suppress redundant givens during error reporting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC is unable to solve a constraint and prints out an error message, it +will print out what given constraints are in scope to provide some context to +the programmer. But we shouldn't print out /every/ given, since some of them +are not terribly helpful to diagnose type errors. Consider this example: + + foo :: Int :~: Int -> a :~: b -> a :~: c + foo Refl Refl = Refl + +When reporting that GHC can't solve (a ~ c), there are two givens in scope: +(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., +redundant), so it's not terribly useful to report it in an error message. +To accomplish this, we discard any Implications that do not bind any +equalities by filtering the `givens` selected in `misMatchOrCND` (based on +the `ic_given_eqs` field of the Implication). Note that we discard givens +that have no equalities whatsoever, but we want to keep ones with only *local* +equalities, as these may be helpful to the user in understanding what went +wrong. + +But this is not enough to avoid all redundant givens! Consider this example, +from #15361: + + goo :: forall (a :: Type) (b :: Type) (c :: Type). + a :~~: b -> a :~~: c + goo HRefl = HRefl + +Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. +The (* ~ *) part arises due the kinds of (:~~:) being unified. More +importantly, (* ~ *) is redundant, so we'd like not to report it. However, +the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its +ic_given_eqs field), so the test above will keep it wholesale. + +To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) +part. This works because mkMinimalBySCs eliminates reflexive equalities in +addition to superclasses (see Note [Remove redundant provided dicts] +in GHC.Tc.TyCl.PatSyn). +-} + +extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcReportInfo] +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarEqInfo tv1 ty2 + = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2 + where + ty_extra ty = case tcGetCastedTyVar_maybe ty of + Just (tv, _) -> (:[]) <$> extraTyVarInfo tv + Nothing -> return [] + +extraTyVarInfo :: TcTyVar -> TcM TcReportInfo +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info lvl overlaps -> do + new_skol_info <- zonkSkolemInfo skol_info + return $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)) + _ -> return $ TyVarInfo tv + + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 _ty2 + | bndr : bndrs <- inferred_bndrs + = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) + | otherwise + = Nothing + where + inferred_bndrs = + case tcGetTyVar_maybe ty1 of + Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv + _ -> [] + + -- 'find' returns the binders of an InferSkol for 'tv', + -- provided there is an intervening implication with + -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) + find [] _ _ = [] + find (implic:implics) seen_eqs tv + | tv `elem` ic_skols implic + , InferSkol prs <- ic_info implic + , seen_eqs + = map fst prs + | otherwise + = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv + +-------------------- + +mkMismatchMsg :: Ct -> Type -> Type -> TcReportMsg +mkMismatchMsg ct ty1 ty2 = + case ctOrigin ct of + TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> + mkTcReportWithInfo + (TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_ct = ct + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_actual = uo_actual + , teq_mismatch_expected = uo_expected + , teq_mismatch_what = mb_thing}) + extras + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> + mkTcReportWithInfo (Mismatch False ct ty1 ty2) + (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) + _ -> + mkTcReportWithInfo + (Mismatch False ct ty1 ty2) + extras + where + orig = ctOrigin ct + extras = sameOccExtras ty2 ty1 + ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig + +-- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to +-- check for a kind mismatch (as these types typically have more surrounding +-- types and are likelier to be able to glean information about whether a +-- mismatch occurred in an invisible argument position or not). If the +-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types +-- themselves. +shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool +shouldPprWithExplicitKinds ty1 ty2 ct + = tcEqTypeVis act_ty exp_ty + -- True when the visible bit of the types look the same, + -- so we want to show the kinds in the displayed type. + where + (act_ty, exp_ty) = case ct of + TypeEqOrigin { uo_actual = act + , uo_expected = exp } -> (act, exp) + _ -> (ty1, ty2) + +{- Note [Insoluble occurs check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble +so we don't use it for rewriting. The Wanted is also insoluble, and +we don't solve it from the Given. It's very confusing to say + Cannot solve a ~ [a] from given constraints a ~ [a] + +And indeed even thinking about the Givens is silly; [W] a ~ [a] is +just as insoluble as Int ~ Bool. + +Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) +then report it directly, not in the "cannot deduce X from Y" form. +This is done in misMatchOrCND (via the insoluble_occurs_check arg) + +(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't +want to be as draconian with them.) +-} + +sameOccExtras :: TcType -> TcType -> [TcReportInfo] +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtras ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = [SameOcc same_pkg n1 n2] + | otherwise + = [] + +{- Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +More specifically, we suggest adding a type sig if we have p ~ ty, and +p is a skolem bound by an InferSkol. Those skolems were created from +unification variables in simplifyInfer. Why didn't we unify? It must +have been because of an intervening GADT or existential, making it +untouchable. Either way, a type signature would help. For GADTs, it +might make it typeable; for existentials the attempt to write a +signature will fail -- or at least will produce a better error message +next time + +This initially came up in #8968, concerning pattern synonyms. + +Note [Disambiguating (X ~ X) errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #8278 + +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer something like + f :: forall a. a -> [a] +with a deferred error of (a ~ [a]). So in the deferred unsolved constraint +'a' is now a skolem, but not one bound by the programmer in the context! +Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + +Note [Non-injective type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very confusing to get a message like + Couldn't match expected type `Depend s' + against inferred type `Depend s1' +so mkTyFunInfoMsg adds: + NB: `Depend' is type function, and hence may not be injective + +Warn of loopy local equalities that were dropped. + + +************************************************************************ +* * + Type-class errors +* * +************************************************************************ +-} + +mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM SolverReport +mkDictErr ctxt cts + = assert (not (null cts)) $ + do { inst_envs <- tcGetInstEnvs + ; let min_cts = elim_superclasses cts + lookups = map (lookup_cls_inst inst_envs) min_cts + (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- But we report only one of them (hence 'head') because they all + -- have the same source-location origin, to try avoid a cascade + -- of error from one location + ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; return $ important ctxt err } + where + no_givens = null (getUserGivens ctxt) + + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct)) + + lookup_cls_inst inst_envs ct + = (ct, lookupInstEnv True inst_envs clas tys) + where + (clas, tys) = getClassPredTys (ctPred ct) + + + -- When simplifying [W] Ord (Set a), we need + -- [W] Eq a, [W] Ord a + -- but we really only want to report the latter + elim_superclasses cts = mkMinimalBySCs ctPred cts + +-- [Note: mk_dict_err] +-- ~~~~~~~~~~~~~~~~~~~ +-- Different dictionary error messages are reported depending on the number of +-- matches and unifiers: +-- +-- - No matches, regardless of unifiers: report "No instance for ...". +-- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", +-- and show the matching and unifying instances. +-- - One match, one or more unifiers: report "Overlapping instances for", show the +-- matching and unifying instances, and say "The choice depends on the instantion of ..., +-- and the result of evaluating ...". +mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM TcReportMsg +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) + | null matches -- No matches but perhaps several unifiers + = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct + ; candidate_insts <- get_candidate_instances + ; (imp_errs, field_suggestions) <- record_field_suggestions + ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) } + + | null unsafe_overlapped -- Some matches => overlap errors + = return $ overlap_msg + + | otherwise + = return $ safe_haskell_msg + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] + + get_candidate_instances :: TcM [ClsInst] + -- See Note [Report candidate instances] + get_candidate_instances + | [ty] <- tys -- Only try for single-parameter classes + = do { instEnvs <- tcGetInstEnvs + ; return (filter (is_candidate_inst ty) + (classInstances instEnvs clas)) } + | otherwise = return [] + + is_candidate_inst ty inst -- See Note [Report candidate instances] + | [other_ty] <- is_tys inst + , Just (tc1, _) <- tcSplitTyConApp_maybe ty + , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty + = let n1 = tyConName tc1 + n2 = tyConName tc2 + different_names = n1 /= n2 + same_occ_names = nameOccName n1 == nameOccName n2 + in different_names && same_occ_names + | otherwise = False + + -- See Note [Out-of-scope fields with -XOverloadedRecordDot] + record_field_suggestions :: TcM ([ImportError], [GhcHint]) + record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name -> + do { glb_env <- getGlobalRdrEnv + ; lcl_env <- getLocalRdrEnv + ; if occ_name_in_scope glb_env lcl_env name + then return ([], noHints) + else do { dflags <- getDynFlags + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod + glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } + + occ_name_in_scope glb_env lcl_env occ_name = not $ + null (lookupGlobalRdrEnv glb_env occ_name) && + isNothing (lookupLocalRdrOcc lcl_env occ_name) + + record_field = case orig of + HasFieldOrigin name -> Just (mkVarOccFS name) + _ -> Nothing + + cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg + cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions + = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds + + -- Overlap errors. + overlap_msg, safe_haskell_msg :: TcReportMsg + -- Normal overlap error + overlap_msg + = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers + + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg + = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ + UnsafeOverlap ct ispecs unsafe_ispecs + +{- Note [Report candidate instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved (Num Int), where `Int` is not the Prelude Int, +but comes from some other module, then it may be helpful to point out +that there are some similarly named instances elsewhere. So we get +something like + No instance for (Num Int) arising from the literal ‘3’ + There are instances for similar types: + instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ +Discussion in #9611. + +Note [Highlighting ambiguous type variables] +~------------------------------------------- +When we encounter ambiguous type variables (i.e. type variables +that remain metavariables after type inference), we need a few more +conditions before we can reason that *ambiguity* prevents constraints +from being solved: + - We can't have any givens, as encountering a typeclass error + with given constraints just means we couldn't deduce + a solution satisfying those constraints and as such couldn't + bind the type variable to a known type. + - If we don't have any unifiers, we don't even have potential + instances from which an ambiguity could arise. + - Lastly, I don't want to mess with error reporting for + unknown runtime types so we just fall back to the old message there. +Once these conditions are satisfied, we can safely say that ambiguity prevents +the constraint from being solved. + +Note [Out-of-scope fields with -XOverloadedRecordDot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XOverloadedRecordDot, when a field isn't in scope, the error that appears +is produces here, and it says + No instance for (GHC.Record.HasField "" ...). + +Additionally, though, we want to suggest similar field names that are in scope +or could be in scope with different import lists. + +However, we can still get an error about a missing HasField instance when a +field is in scope (if the types are wrong), and so it's important that we don't +suggest similar names here if the record field is in scope, either qualified or +unqualified, since qualification doesn't matter for -XOverloadedRecordDot. + +Example: + + import Data.Monoid (Alt(..)) + + foo = undefined.getAll + +results in + + No instance for (GHC.Records.HasField "getAll" r0 a0) + arising from selecting the field ‘getAll’ + Perhaps you meant ‘getAlt’ (imported from Data.Monoid) + Perhaps you want to add ‘getAll’ to the import list + in the import of ‘Data.Monoid’ +-} + +{- +Note [Kind arguments in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag +whenever any error message arises due to a kind mismatch. This means that +the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. +-} + +getAmbigTkvs :: Ct -> ([Var],[Var]) +getAmbigTkvs ct + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfCtList ct + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + +----------------------- +-- relevantBindings looks at the value environment and finds values whose +-- types mention any of the offending type variables. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf #8233) + +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See #8191 + -> ReportErrCtxt -> Ct + -> TcM (ReportErrCtxt, RelevantBindings, Ct) +-- Also returns the zonked and tidied CtOrigin of the constraint +relevantBindings want_filtering ctxt ct + = do { traceTc "relevantBindings" (ppr ct) + ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + ; let extra_tvs = case tidy_orig of + KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] + _ -> emptyVarSet + ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs + + -- Put a zonked, tidied CtOrigin into the Ct + loc' = setCtLocOrigin loc tidy_orig + ct' = setCtLoc ct loc' + + ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] + + ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs + ; let ctxt' = ctxt { cec_tidy = env2 } + ; return (ctxt', relev_bds, ct') } + where + loc = ctLoc ct + lcl_env = ctLocEnv loc + +-- slightly more general version, to work also with holes +relevant_bindings :: Bool + -> TcLclEnv + -> NameEnv Type -- Cache of already zonked and tidied types + -> TyCoVarSet + -> TcM RelevantBindings +relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs + = do { dflags <- getDynFlags + ; traceTc "relevant_bindings" $ + vcat [ ppr ct_tvs + , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) + | TcIdBndr id _ <- tcl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] + + ; go dflags (maxRelevantBinds dflags) + emptyVarSet (RelevantBindings [] False) + (removeBindingShadowing $ tcl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones + } + where + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + + go :: DynFlags -> Maybe Int -> TcTyVarSet + -> RelevantBindings + -> [TcBinder] + -> TcM RelevantBindings + go _ _ _ (RelevantBindings bds discards) [] + = return $ RelevantBindings (reverse bds) discards + go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs) + = case tc_bndr of + TcTvBndr {} -> discard_it + TcIdBndr id top_lvl -> go2 (idName id) top_lvl + TcIdBndr_ExpType name et top_lvl -> + do { mb_ty <- readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just _ty -> go2 name top_lvl + Nothing -> discard_it -- No info; discard + } + where + discard_it = go dflags n_left tvs_seen rels tc_bndrs + go2 id_name top_lvl + = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of + Just tty -> tty + Nothing -> pprPanic "relevant_bindings" (ppr id_name) + ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyCoVarsOfType tidy_ty + bd = (id_name, tidy_ty) + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not (hasPprDebug dflags) + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then discard_it + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then discard_it + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions already-seen type variables, so discard it + then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something + tc_bndrs + + -- Keep this binding, decrement fuel + else go dflags (dec_max n_left) new_seen + (RelevantBindings (bd:bds) discards) tc_bndrs } + +----------------------- +warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () +warnDefaulting _ [] _ + = panic "warnDefaulting: empty Wanteds" +warnDefaulting the_tv wanteds@(ct:_) default_ty + = do { warn_default <- woptM Opt_WarnTypeDefaults + ; env0 <- tcInitTidyEnv + ; let tidy_env = tidyFreeTyCoVars env0 $ + tyCoVarsOfCtsList (listToBag wanteds) + tidy_wanteds = map (tidyCt tidy_env) wanteds + tidy_tv = lookupVarEnv (snd tidy_env) the_tv + diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + loc = ctLoc ct ; setCtLocM loc $ diagnosticTc warn_default diag } {- diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -32,6 +32,8 @@ import GHC.Prelude +import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits ) import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint @@ -413,12 +415,6 @@ `a`, where `a` is a skolem. -} -data HoleFitDispConfig = HFDC { showWrap :: Bool - , showWrapVars :: Bool - , showType :: Bool - , showProv :: Bool - , showMatches :: Bool } - -- We read the various -no-show-*-of-hole-fits flags -- and set the display config accordingly. getHoleFitDispConfig :: TcM HoleFitDispConfig @@ -560,14 +556,13 @@ -- ^ The unsolved simple constraints in the implication for -- the hole. -> Hole - -> TcM (TidyEnv, SDoc) + -> TcM (TidyEnv, ValidHoleFits) findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ , hole_loc = ct_loc , hole_ty = hole_ty }) = do { rdr_env <- getGlobalRdrEnv ; lclBinds <- getLocalBindings tidy_env ct_loc ; maxVSubs <- maxValidHoleFits <$> getDynFlags - ; hfdc <- getHoleFitDispConfig ; sortingAlg <- getHoleFitSortingAlg ; dflags <- getDynFlags ; hfPlugs <- tcg_hf_plugins <$> getGblEnv @@ -607,12 +602,11 @@ ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs vDiscards = pVDisc || searchDiscards ; subs_with_docs <- addHoleFitDocs limited_subs - ; let vMsg = ppUnless (null subs_with_docs) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) subs_with_docs) - $$ ppWhen vDiscards subsDiscardMsg + ; let subs = Fits subs_with_docs vDiscards -- Refinement hole fits. See Note [Valid refinement hole fits include ...] - ; (tidy_env, refMsg) <- if refLevel >= Just 0 then + ; (tidy_env, rsubs) <- + if refLevel >= Just 0 + then do { maxRSubs <- maxRefHoleFits <$> getDynFlags -- We can use from just, since we know that Nothing >= _ is False. ; let refLvls = [1..(fromJust refLevel)] @@ -640,14 +634,11 @@ possiblyDiscard maxRSubs $ plugin_handled_rsubs rDiscards = pRDisc || any fst refDs ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits - ; return (tidy_env, - ppUnless (null rsubs_with_docs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) rsubs_with_docs) - $$ ppWhen rDiscards refSubsDiscardMsg) } - else return (tidy_env, empty) + ; return (tidy_env, Fits rsubs_with_docs rDiscards) } + else return (tidy_env, Fits [] False) ; traceTc "findingValidHoleFitsFor }" empty - ; return (tidy_env, vMsg $$ refMsg) } + ; let hole_fits = ValidHoleFits subs rsubs + ; return (tidy_env, hole_fits) } where -- We extract the TcLevel from the constraint. hole_lvl = ctLocLevel ct_loc @@ -688,19 +679,6 @@ <*> sortHoleFitsByGraph (sort gblFits) where (lclFits, gblFits) = span hfIsLcl subs - subsDiscardMsg :: SDoc - subsDiscardMsg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - - refSubsDiscardMsg :: SDoc - refSubsDiscardMsg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - - -- Based on the flags, we might possibly discard some or all the -- fits we've found. possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) @@ -709,7 +687,7 @@ -- We don't (as of yet) handle holes in types, only in expressions. -findValidHoleFits env _ _ _ = return (env, empty) +findValidHoleFits env _ _ _ = return (env, noValidHoleFits) -- See Note [Relevant constraints] relevantCts :: Type -> [Ct] -> [Ct] diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -5,6 +5,7 @@ module GHC.Tc.Errors.Hole where import GHC.Types.Var ( Id ) +import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) @@ -18,7 +19,7 @@ import Data.Int ( Int ) findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole - -> TcM (TidyEnv, SDoc) + -> TcM (TidyEnv, ValidHoleFits) tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType -> TcM (Bool, HsWrapper) @@ -30,7 +31,6 @@ getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] -data HoleFitDispConfig data HoleFitSortingAlg pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -862,7 +862,7 @@ go1 delta acc so_far fun_ty (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald - (Just (ppr rn_fun)) + (Just $ HsExprRnThing rn_fun) (n_val_args, so_far) fun_ty ; (delta', arg') <- if do_ql then addArgCtxt ctxt arg $ @@ -1238,7 +1238,7 @@ -- Passes the occurs check = do { let ty2_kind = typeKind ty2 kappa_kind = tyVarKind kappa - ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind + ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind -- unifyKind: see Note [Actual unification in qlUnify] ; traceTc "qlUnify:update" $ diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -184,7 +184,8 @@ -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. - ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] + ; skol_info <- mkSkolemInfo ArrowReboundIfSkol + ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty)) TcRnArrowIfThenElsePredDependsOnResultTy diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -179,13 +179,10 @@ -- The TcLclEnv has an extended type envt for the new bindings tcTopBinds binds sigs = do { -- Pattern synonym bindings populate the global environment - (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $ - do { gbl <- getGblEnv - ; lcl <- getLclEnv - ; return (gbl, lcl) } + (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs + ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs ; traceTc "complete_matches" (ppr binds $$ ppr sigs) ; traceTc "complete_matches" (ppr complete_matches) @@ -788,6 +785,9 @@ sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty -- This type is just going into tcSubType, -- so Inferred vs. Specified doesn't matter + + ; traceTc "mkExport" (vcat [ ppr poly_id <+> dcolon <+> ppr poly_ty + , ppr sel_poly_ty ]) ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility then return idHsWrapper -- Fast path; also avoids complaint when we infer diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -455,9 +455,10 @@ [p_ty] ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] ; loc <- getSrcSpanM + ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName ; return $ mkHsWrapCo co $ HsApp noComments (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) - (L (noAnnSrcSpan loc) (HsStatic fvs expr')) + (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) } {- @@ -781,7 +782,7 @@ scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty + ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty -- NB: normal unification is OK here (as opposed to subsumption), -- because for this to work out, both record_rho and scrut_ty have -- to be normal datatypes -- no contravariant stuff can go on diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -46,7 +47,6 @@ import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core.UsageEnv ( unitUE ) -import GHC.Rename.Utils ( unknownSubordinateErr ) import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module ( getModule ) import GHC.Tc.Errors.Types @@ -71,6 +71,7 @@ import GHC.Builtin.Types( multiplicityTy ) import GHC.Builtin.Names import GHC.Builtin.Names.TH( liftStringName, liftName ) +import GHC.Driver.Env import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -546,8 +547,8 @@ fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr - = TcRnUnknownMessage $ mkPlainError noHints $ - unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + = mkTcRnNotInScope rdr $ + UnknownSubordinate (text "field of type" <+> quotes (ppr p)) notSelector :: Name -> TcRnMessage notSelector field @@ -674,10 +675,10 @@ do { from_id <- tcLookupId from_name ; (wrap1, from_ty) <- topInstantiate orig (idType from_id) - ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing (1, []) from_ty ; hs_lit <- mkOverLit val - ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) + ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ HsLit noAnn hs_lit @@ -689,9 +690,9 @@ , ol_type = res_ty } } ; return (HsOverLit noAnn lit', res_ty) } where - orig = LiteralOrigin lit - mb_doc = Just (ppr from_name) - herald = sep [ text "The function" <+> quotes (ppr from_name) + orig = LiteralOrigin lit + mb_thing = Just (NameThing from_name) + herald = sep [ text "The function" <+> quotes (ppr from_name) , text "is applied to"] @@ -751,8 +752,7 @@ AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps - AGlobal (ATyCon tc) -> fail_tycon tc - ATcTyCon tc -> fail_tycon tc + (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon ATyVar name _ -> fail_tyvar name _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ @@ -760,20 +760,28 @@ where fail_tycon tc = do gre <- getGlobalRdrEnv - let msg = text "Illegal term-level use of the type constructor" - <+> quotes (ppr (tyConName tc)) - pprov = case lookupGRE_Name gre (tyConName tc) of - Just gre -> nest 2 (pprNameProvenance gre) - Nothing -> empty - suggestions <- get_suggestions dataName - failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) + let nm = tyConName tc + pprov = case lookupGRE_Name gre nm of + Just gre -> nest 2 (pprNameProvenance gre) + Nothing -> empty + fail_with_msg dataName nm pprov - fail_tyvar name = do - let msg = text "Illegal term-level use of the type variable" - <+> quotes (ppr name) - pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc name)) - suggestions <- get_suggestions varName - failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions)) + fail_tyvar nm = + let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm)) + in fail_with_msg varName nm pprov + + fail_with_msg whatName nm pprov = do + (import_errs, hints) <- get_suggestions whatName + unit_state <- hsc_units <$> getTopEnv + let + -- TODO: unfortunate to have to convert to SDoc here. + -- This should go away once we refactor ErrInfo. + hint_msg = vcat $ map ppr hints + import_err_msg = vcat $ map ppr import_errs + info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } + msg = TcRnMessageWithInfo unit_state + $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False) + failWithTc msg get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -5,4281 +5,4379 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - --- | Typechecking user-specified @MonoTypes@ -module GHC.Tc.Gen.HsType ( - -- Type signatures - kcClassSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - tcStandaloneKindSig, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcDerivStrategy, - tcHsTypeApp, - UserTypeCtxt(..), - bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, - bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, - bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - - bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv, - tcOuterTKBndrs, scopedSortOuter, - bindOuterSigTKBndrs_Tv, - tcExplicitTKBndrs, - bindNamedWildCardBinders, - - -- Type checking type and class decls, and instances thereof - bindTyClTyVars, tcFamTyPats, - etaExpandAlgTyCon, tcbVisibilities, - - -- tyvars - zonkAndScopedSort, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - InitialKindStrategy(..), - SAKS_or_CUSK(..), - ContextKind(..), - kcDeclHeader, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, - tcCheckLHsType, - tcHsContext, tcLHsPredType, - - kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, - - -- Sort-checking kinds - tcLHsKindSig, checkDataKindSig, DataSort(..), - checkClassKindSig, - - -- Multiplicity - tcMult, - - -- Pattern type signatures - tcHsPatSigType, - HoleMode(..), - - -- Error messages - funAppCtxt, addTyConFlavCtxt - ) where - -import GHC.Prelude - -import GHC.Hs -import GHC.Rename.Utils -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Types.Origin -import GHC.Core.Predicate -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcMType -import GHC.Tc.Validity -import GHC.Tc.Utils.Unify -import GHC.IfaceToCore -import GHC.Tc.Solver -import GHC.Tc.Utils.Zonk -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, - tcInstInvisibleTyBinder ) -import GHC.Core.Type -import GHC.Builtin.Types.Prim -import GHC.Types.Error -import GHC.Types.Name.Env -import GHC.Types.Name.Reader( lookupLocalRdrOcc ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Types.Name --- import GHC.Types.Name.Set -import GHC.Types.Var.Env -import GHC.Builtin.Types -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Utils.Misc -import GHC.Types.Unique.Supply -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString -import GHC.Builtin.Names hiding ( wildCardName ) -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.Maybe -import GHC.Data.Bag( unitBag ) -import Data.List ( find ) -import Control.Monad - -{- - ---------------------------- - General notes - ---------------------------- - -Unlike with expressions, type-checking types both does some checking and -desugars at the same time. This is necessary because we often want to perform -equality checks on the types right away, and it would be incredibly painful -to do this on un-desugared types. Luckily, desugared types are close enough -to HsTypes to make the error messages sane. - -During type-checking, we perform as little validity checking as possible. -Generally, after type-checking, you will want to do validity checking, say -with GHC.Tc.Validity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies - -Also, in a mutually recursive group of types, we can't look at the TyCon until we've -finished building the loop. So to keep things simple, we postpone most validity -checking until step (3). - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ - -Note [Keeping implicitly quantified variables in order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user implicitly quantifies over variables (say, in a type -signature), we need to come up with some ordering on these variables. -This is done by bumping the TcLevel, bringing the tyvars into scope, -and then type-checking the thing_inside. The constraints are all -wrapped in an implication, which is then solved. Finally, we can -zonk all the binders and then order them with scopedSort. - -It's critical to solve before zonking and ordering in order to uncover -any unifications. You might worry that this eager solving could cause -trouble elsewhere. I don't think it will. Because it will solve only -in an increased TcLevel, it can't unify anything that was mentioned -elsewhere. Additionally, we require that the order of implicitly -quantified variables is manifest by the scope of these variables, so -we're not going to learn more information later that will help order -these variables. - -Note [Recipe for checking a signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind-checking a user-written signature requires several steps: - - 0. Bump the TcLevel - 1. Bind any lexically-scoped type variables. - 2. Generate constraints. - 3. Solve constraints. - 4. Sort any implicitly-bound variables into dependency order - 5. Promote tyvars and/or kind-generalize. - 6. Zonk. - 7. Check validity. - -Very similar steps also apply when kind-checking a type or class -declaration. - -The general pattern looks something like this. (But NB every -specific instance varies in one way or another!) - - do { (tclvl, wanted, (spec_tkvs, ty)) - <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ - bindImplicitTKBndrs_Skol sig_vars $ - - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - - ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted - - ; let ty1 = mkSpecForAllTys spec_tkvs ty - ; kvs <- kindGeneralizeAll ty1 - - ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) - - ; checkValidType final_ty - -This pattern is repeated many times in GHC.Tc.Gen.HsType, -GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail: - -* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel, - calls the thing inside to generate constraints, solves those - constraints as much as possible, returning the residual unsolved - constraints in 'wanted'. - -* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type - variables E.g. when kind-checking f :: forall a. F a -> a we must - bring 'a' into scope before kind-checking (F a -> a) - -* zonkAndScopedSort (Step 4) puts those user-specified variables in - the dependency order. (For "implicit" variables the order is no - user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are - implicitly brought into scope. - -* reportUnsolvedEqualities (Step 3 continued) reports any unsolved - equalities, carefully wrapping them in an implication that binds the - skolems. We can't do that in pushLevelAndSolveEqualitiesX because - that function doesn't have access to the skolems. - -* kindGeneralize (Step 5). See Note [Kind generalisation] - -* The final zonkTcTypeToType must happen after promoting/generalizing, - because promoting and generalizing fill in metavariables. - - -Doing Step 3 (constraint solving) eagerly (rather than building an -implication constraint and solving later) is necessary for several -reasons: - -* Exactly as for Solver.simplifyInfer: when generalising, we solve all - the constraints we can so that we don't have to quantify over them - or, since we don't quantify over constraints in kinds, float them - and inhibit generalisation. - -* Most signatures also bring implicitly quantified variables into - scope, and solving is necessary to get these in the right order - (Step 4) see Note [Keeping implicitly quantified variables in - order]). - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Step 5 of Note [Recipe for checking a signature], namely -kind-generalisation, is done by - kindGeneraliseAll - kindGeneraliseSome - kindGeneraliseNone - -Here, we have to deal with the fact that metatyvars generated in the -type will have a bumped TcLevel, because explicit foralls raise the -TcLevel. To avoid these variables from ever being visible in the -surrounding context, we must obey the following dictum: - - Every metavariable in a type must either be - (A) generalized, or - (B) promoted, or See Note [Promotion in signatures] - (C) a cause to error See Note [Naughty quantification candidates] - in GHC.Tc.Utils.TcMType - -There are three steps (look at kindGeneraliseSome): - -1. candidateQTyVarsOfType finds the free variables of the type or kind, - to generalise - -2. filterConstrainedCandidates filters out candidates that appear - in the unsolved 'wanteds', and promotes the ones that get filtered out - thereby. - -3. quantifyTyVars quantifies the remaining type variables - -The kindGeneralize functions do not require pre-zonking; they zonk as they -go. - -kindGeneraliseAll specialises for the case where step (2) is vacuous. -kindGeneraliseNone specialises for the case where we do no quantification, -but we must still promote. - -If you are actually doing kind-generalization, you need to bump the -level before generating constraints, as we will only generalize -variables with a TcLevel higher than the ambient one. -Hence the "pushLevel" in pushLevelAndSolveEqualities. - -Note [Promotion in signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If an unsolved metavariable in a signature is not generalized -(because we're not generalizing the construct -- e.g., pattern -sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (WantedTvInv) of Note [TcLevel invariants] -in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing -and the reinstantiating with a fresh metavariable at the current level. -So in some sense, we generalize *all* variables, but then re-instantiate -some of them. - -Here is an example of why we must promote: - foo (x :: forall a. a -> Proxy b) = ... - -In the pattern signature, `b` is unbound, and will thus be brought into -scope. We do not know its kind: it will be assigned kappa[2]. Note that -kappa is at TcLevel 2, because it is invented under a forall. (A priori, -the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel -than the surrounding context.) This kappa cannot be solved for while checking -the pattern signature (which is not kind-generalized). When we are checking -the *body* of foo, though, we need to unify the type of x with the argument -type of bar. At this point, the ambient TcLevel is 1, and spotting a -matavariable with level 2 would violate the (WantedTvInv) invariant of -Note [TcLevel invariants]. So, instead of kind-generalizing, -we promote the metavariable to level 1. This is all done in kindGeneralizeNone. - --} - -funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLocA hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc --- (pprSigCtxt ctxt ) --- prints In the type signature for 'f': --- f :: --- The is either empty or "the ambiguity check for" -pprSigCtxt ctxt hs_ty - | Just n <- isSigMaybe ctxt - = hang (text "In the type signature:") - 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) - - | otherwise - = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) - 2 (ppr hs_ty) - -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildcards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () --- This is a special form of tcClassSigType that is used during the --- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. --- Importantly, this does *not* kind-generalize. Consider --- class SC f where --- meth :: forall a (x :: f a). Proxy x -> () --- When instantiating Proxy with kappa, we must unify kappa := f a. But we're --- still working out the kind of f, and thus f a will have a coercion in it. --- Coercions block unification (Note [Equalities with incompatible kinds] in --- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll --- end up promoting kappa to the top level (because kind-generalization is --- normally done right before adding a binding to the context), and then we --- can't set kappa := f a, because a is local. -kcClassSigType names - sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty })) - = addSigCtxt (funsSigCtxt names) sig_ty $ - do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $ - tcLHsType hs_ty liftedTypeKind - ; return () } - -tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type --- Does not do validity checking -tcClassSigType names sig_ty - = addSigCtxt sig_ctxt sig_ty $ - do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) - ; emitImplication implic - ; return ty } - -- Do not zonk-to-Type, nor perform a validity check - -- We are in a knot with the class and associated types - -- Zonking and validity checking is done by tcClassDecl - -- - -- No need to fail here if the type has an error: - -- If we're in the kind-checking phase, the solveEqualities - -- in kcTyClGroup catches the error - -- If we're in the type-checking phase, the solveEqualities - -- in tcClassDecl1 gets it - -- Failing fast here degrades the error message in, e.g., tcfail135: - -- class Foo f where - -- baa :: f a -> f - -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. - -- It should be that f has kind `k2 -> *`, but we never get a chance - -- to run the solver where the kind of f is touchable. This is - -- painfully delicate. - where - sig_ctxt = funsSigCtxt names - skol_info = SigTypeSkol sig_ctxt - -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- Does validity checking --- See Note [Recipe for checking a signature] -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt sig_ty $ - do { traceTc "tcHsSigType {" (ppr sig_ty) - - -- Generalise here: see Note [Kind generalisation] - ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) - - -- Float out constraints, failing fast if not possible - -- See Note [Failure in local type signatures] in GHC.Tc.Solver - ; traceTc "tcHsSigType 2" (ppr implic) - ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) - - ; ty <- zonkTcType ty - ; checkValidType ctxt ty - ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } - where - skol_info = SigTypeSkol ctxt - -tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Implication, TcType) --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities internally. --- No validity checking or zonking --- Returns also an implication for the unsolved constraints -tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs - , sig_body = hs_ty })) ctxt_kind - = setSrcSpanA loc $ - do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty))) - <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ - -- See Note [Failure in local type signatures] - do { exp_kind <- newExpectedKind ctxt_kind - -- See Note [Escaping kind in type signatures] - ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $ - tcLHsType hs_ty exp_kind - ; return (exp_kind, stuff) } - - -- Default any unconstrained variables free in the kind - -- See Note [Escaping kind in type signatures] - ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind - ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind) - - ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) - ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs - - ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty - - ; kvs <- kindGeneralizeSome wanted ty1 - - -- Build an implication for any as-yet-unsolved kind equalities - -- See Note [Skolem escape in type signatures] - ; implic <- buildTvImplication skol_info kvs tc_lvl wanted - - ; return (implic, mkInfForAllTys kvs ty1) } - where - mk_doc exp_kind tidy_env - = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind - ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind) - 2 (text "of type signature:" <+> ppr full_hs_ty)) } - - - -{- Note [Escaping kind in type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider kind-checking the signature for `foo` (#19495): - type family T (r :: RuntimeRep) :: TYPE r - - foo :: forall (r :: RuntimeRep). T r - foo = ... - -We kind-check the type with expected kind `TYPE delta` (see newExpectedKind), -where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep` -because we allow signatures like `foo :: Int#`.) - -Suppose we are at level L currently. We do this - * pushLevelAndSolveEqualitiesX: moves to level L+1 - * newExpectedKind: allocates delta{L+1} - * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2} - * kind-check the body (T r) :: TYPE delta{L+1} - -Then -* We can't unify delta{L+1} with r{L+2}. - And rightly so: skolem would escape. - -* If delta{L+1} is unified with some-kind{L}, that is fine. - This can happen - \(x::a) -> let y :: a; y = x in ...(x :: Int#)... - Here (x :: a :: TYPE gamma) is in the environment when we check - the signature y::a. We unify delta := gamma, and all is well. - -* If delta{L+1} is unconstrained, we /must not/ quantify over it! - E.g. Consider f :: Any where Any :: forall k. k - We kind-check this with expected kind TYPE kappa. We get - Any @(TYPE kappa) :: TYPE kappa - We don't want to generalise to forall k. Any @k - because that is ill-kinded: the kind of the body of the forall, - (Any @k :: k) mentions the bound variable k. - - Instead we want to default it to LiftedRep. - - An alternative would be to promote it, similar to the monomorphism - restriction, but the MR is pretty confusing. Defaulting seems better - -How does that defaulting happen? Well, since we /currently/ default -RuntimeRep variables during generalisation, it'll happen in -kindGeneralize. But in principle we might allow generalisation over -RuntimeRep variables in future. Moreover, what if we had - kappa{L+1} := F alpha{L+1} -where F :: Type -> RuntimeRep. Now it's alpha that is free in the kind -and it /won't/ be defaulted. - -So we use doNotQuantifyTyVars to either default the free vars of -exp_kind (if possible), or error (if not). - -Note [Skolem escape in type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcHsSigType is tricky. Consider (T11142) - foo :: forall b. (forall k (a :: k). SameKind a b) -> () -This is ill-kinded because of a nested skolem-escape. - -That will show up as an un-solvable constraint in the implication -returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem -escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable -(the unification variable for b's kind is untouchable). - -Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType) -we'll try to float out the constraint, be unable to do so, and fail. -See GHC.Tc.Solver Note [Failure in local type signatures] for more -detail on this. - -The separation between tcHsSigType and tc_lhs_sig_type is because -tcClassSigType wants to use the latter, but *not* fail fast, because -there are skolems from the class decl which are in scope; but it's fine -not to because tcClassDecl1 has a solveEqualities wrapped around all -the tcClassSigType calls. - -That's why tcHsSigType does simplifyAndEmitFlatConstraints (which -fails fast) but tcClassSigType just does emitImplication (which does -not). Ugh. - -c.f. see also Note [Skolem escape and forall-types]. The difference -is that we don't need to simplify at a forall type, only at the -top level of a signature. --} - --- Does validity checking and zonking. -tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) -tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig)) - = addSigCtxt ctxt ksig $ - do { kind <- tc_top_lhs_type KindLevel ctxt ksig - ; checkValidType ctxt kind - ; return (name, kind) } - where - ctxt = StandaloneKindSigCtxt name - -tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -tcTopLHsType ctxt lsig_ty - = tc_top_lhs_type TypeLevel ctxt lsig_ty - -tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where --- we want to fully solve /all/ equalities, and report errors --- Does zonking, but not validity checking because it's used --- for things (like deriving and instances) that aren't --- ordinary types --- Used for both types and kinds -tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs - , sig_body = body })) - = setSrcSpanA loc $ - do { traceTc "tc_top_lhs_type {" (ppr sig_ty) - ; (tclvl, wanted, (outer_bndrs, ty)) - <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ - tcOuterTKBndrs skol_info hs_outer_bndrs $ - do { kind <- newExpectedKind (expectedKindInCtxt ctxt) - ; tc_lhs_type (mkMode tyki) body kind } - - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs - ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty - - ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; reportUnsolvedEqualities skol_info kvs tclvl wanted - - ; ze <- mkEmptyZonkEnv NoFlexi - ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1) - ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) - ; return final_ty } - where - skol_info = SigTypeSkol ctxt - ------------------ -tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) --- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause --- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments --- E.g. class C (a::*) (b::k->k) --- data T a b = ... deriving( C Int ) --- returns ([k], C, [k, Int], [k->k]) --- Return values are fully zonked -tcHsDeriv hs_ty - = do { ty <- checkNoErrs $ -- Avoid redundant error report - -- with "illegal deriving", below - tcTopLHsType DerivClauseCtxt hs_ty - ; let (tvs, pred) = splitForAllTyCoVars ty - (kind_args, _) = splitFunTys (tcTypeKind pred) - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } - --- | Typecheck a deriving strategy. For most deriving strategies, this is a --- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. -tcDerivStrategy :: - Maybe (LDerivStrategy GhcRn) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). -tcDerivStrategy mb_lds - = case mb_lds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpanA loc $ do - (ds', tvs) <- tc_deriv_strategy ds - pure (Just (L loc ds'), tvs) - where - tc_deriv_strategy :: DerivStrategy GhcRn - -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy (StockStrategy _) - = boring_case (StockStrategy noExtField) - tc_deriv_strategy (AnyclassStrategy _) - = boring_case (AnyclassStrategy noExtField) - tc_deriv_strategy (NewtypeStrategy _) - = boring_case (NewtypeStrategy noExtField) - tc_deriv_strategy (ViaStrategy ty) = do - ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty - let (via_tvs, via_pred) = splitForAllTyCoVars ty' - pure (ViaStrategy via_pred, via_tvs) - - boring_case :: ds -> TcM (ds, [TyVar]) - boring_case ds = pure (ds, []) - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType GhcRn - -> TcM Type --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLocA hs_inst_ty) $ - do { -- Fail eagerly if tcTopLHsType fails. We are at top level so - -- these constraints will never be solved later. And failing - -- eagerly avoids follow-on errors when checkValidInstance - -- sees an unsolved coercion hole - inst_ty <- checkNoErrs $ - tcTopLHsType user_ctxt hs_inst_ty - ; checkValidInstance user_ctxt hs_inst_ty inst_ty - ; return inst_ty } - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type --- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType -tcHsTypeApp wc_ty kind - | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { mode <- mkHoleMode TypeLevel HM_VTA - -- HM_VTA: See Note [Wildcards in visible type application] - ; ty <- addTypeCtxt hs_ty $ - solveEqualities "tcHsTypeApp" $ - -- We are looking at a user-written type, very like a - -- signature so we want to solve its equalities right now - bindNamedWildCardBinders sig_wcs $ \ _ -> - tc_lhs_type mode hs_ty kind - - -- We do not kind-generalize type applications: we just - -- instantiate with exactly what the user says. - -- See Note [No generalization in type application] - -- We still must call kindGeneralizeNone, though, according - -- to Note [Recipe for checking a signature] - ; kindGeneralizeNone ty - ; ty <- zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } - -{- Note [Wildcards in visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so -any unnamed wildcards stay unchanged in hswc_body. When called in -tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole -on these anonymous wildcards. However, this would trigger -error/warning when an anonymous wildcard is passed in as a visible type -argument, which we do not want because users should be able to write -@_ to skip a instantiating a type variable variable without fuss. The -solution is to switch the PartialTypeSignatures flags here to let the -typechecker know that it's checking a '@_' and do not emit hole -constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Type - -Ugh! - -Note [No generalization in type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not kind-generalize type applications. Imagine - - id @(Proxy Nothing) - -If we kind-generalized, we would get - - id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) - -which is very sneakily impredicative instantiation. - -There is also the possibility of mentioning a wildcard -(`id @(Proxy _)`), which definitely should not be kind-generalized. - --} - -tcFamTyPats :: TyCon - -> HsTyPats GhcRn -- Patterns - -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) --- Check the LHS of a type/data family instance --- e.g. type instance F ty1 .. tyn = ... --- Used for both type and data families -tcFamTyPats fam_tc hs_pats - = do { traceTc "tcFamTyPats {" $ - vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] - - ; mode <- mkHoleMode TypeLevel HM_FamPat - -- HM_FamPat: See Note [Wildcards in family instances] in - -- GHC.Rename.Module - ; let fun_ty = mkTyConApp fam_tc [] - ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats - - -- Hack alert: see Note [tcFamTyPats: zonking the result kind] - ; res_kind <- zonkTcType res_kind - - ; traceTc "End tcFamTyPats }" $ - vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] - - ; return (fam_app, res_kind) } - where - fam_name = tyConName fam_tc - fam_arity = tyConArity fam_tc - lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name)) - -{- Note [tcFamTyPats: zonking the result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#19250) - F :: forall k. k -> k - type instance F (x :: Constraint) = () - -The tricky point is this: - is that () an empty type tuple (() :: Type), or - an empty constraint tuple (() :: Constraint)? -We work this out in a hacky way, by looking at the expected kind: -see Note [Inferring tuple kinds]. - -In this case, we kind-check the RHS using the kind gotten from the LHS: -see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. - -But we want the kind from the LHS to be /zonked/, so that when -kind-checking the RHS (tcCheckLHsType) we can "see" what we learned -from kind-checking the LHS (tcFamTyPats). In our example above, the -type of the LHS is just `kappa` (by instantiating the forall k), but -then we learn (from x::Constraint) that kappa ~ Constraint. We want -that info when kind-checking the RHS. - -Easy solution: just zonk that return kind. Of course this won't help -if there is lots of type-family reduction to do, but it works fine in -common cases. --} - - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType --- Used for type signatures --- Do not do validity checking -tcHsOpenType hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty -tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty - -tcHsOpenTypeNC hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek } -tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - do { ek <- newExpectedKind exp_kind - ; tcLHsType hs_ty ek } - -tcInferLHsType :: LHsType GhcRn -> TcM TcType -tcInferLHsType hs_ty - = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty - ; return ty } - -tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) --- Called from outside: set the context --- Eagerly instantiate any trailing invisible binders -tcInferLHsTypeKind lhs_ty@(L loc hs_ty) - = addTypeCtxt lhs_ty $ - setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders - do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty - ; tcInstInvisibleTyBinders res_ty res_kind } - -- See Note [Do not always instantiate eagerly in types] - --- Used to check the argument of GHCi :kind --- Allow and report wildcards, e.g. :kind T _ --- Do not saturate family applications: see Note [Dealing with :kind] --- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types] -tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) -tcInferLHsTypeUnsaturated hs_ty - = addTypeCtxt hs_ty $ - do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes - ; case splitHsAppTys (unLoc hs_ty) of - Just (hs_fun_ty, hs_args) - -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty - ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args } - -- Notice the 'nosat'; do not instantiate trailing - -- invisible arguments of a type family. - -- See Note [Dealing with :kind] - Nothing -> tc_infer_lhs_type mode hs_ty } - -{- Note [Dealing with :kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi command - ghci> type family F :: Either j k - ghci> :kind F - F :: forall {j,k}. Either j k - -We will only get the 'forall' if we /refrain/ from saturating those -invisible binders. But generally we /do/ saturate those invisible -binders (see tcInferTyApps), and we want to do so for nested application -even in GHCi. Consider for example (#16287) - ghci> type family F :: k - ghci> data T :: (forall k. k) -> Type - ghci> :kind T F -We want to reject this. It's just at the very top level that we want -to switch off saturation. - -So tcInferLHsTypeUnsaturated does a little special case for top level -applications. Actually the common case is a bare variable, as above. - -Note [Do not always instantiate eagerly in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Terms are eagerly instantiated. This means that if you say - - x = id - -then `id` gets instantiated to have type alpha -> alpha. The variable -alpha is then unconstrained and regeneralized. But we cannot do this -in types, as we have no type-level lambda. So, when we are sure -that we will not want to regeneralize later -- because we are done -checking a type, for example -- we can instantiate. But we do not -instantiate at variables, nor do we in tcInferLHsTypeUnsaturated, -which is used by :kind in GHCi. - -************************************************************************ -* * - Type-checking modes -* * -************************************************************************ - -The kind-checker is parameterised by a TcTyMode, which contains some -information about where we're checking a type. - -The renamer issues errors about what it can. All errors issued here must -concern things that the renamer can't handle. - --} - -tcMult :: HsArrow GhcRn -> TcM Mult -tcMult hc = tc_mult typeLevelMode hc - --- | Info about the context in which we're checking a type. Currently, --- differentiates only between types and kinds, but this will likely --- grow, at least to include the distinction between patterns and --- not-patterns. --- --- To find out where the mode is used, search for 'mode_tyki' --- --- This data type is purely local, not exported from this module -data TcTyMode - = TcTyMode { mode_tyki :: TypeOrKind - , mode_holes :: HoleInfo } - --- See Note [Levels for wildcards] --- Nothing <=> no wildcards expected -type HoleInfo = Maybe (TcLevel, HoleMode) - --- HoleMode says how to treat the occurrences --- of anonymous wildcards; see tcAnonWildCardOcc -data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int - | HM_FamPat -- Family instances: F _ Int = Bool - | HM_VTA -- Visible type and kind application: - -- f @(Maybe _) - -- Maybe @(_ -> _) - | HM_TyAppPat -- Visible type applications in patterns: - -- foo (Con @_ @t x) = ... - -- case x of Con @_ @t v -> ... - -mkMode :: TypeOrKind -> TcTyMode -mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing } - -typeLevelMode, kindLevelMode :: TcTyMode --- These modes expect no wildcards (holes) in the type -kindLevelMode = mkMode KindLevel -typeLevelMode = mkMode TypeLevel - -mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode -mkHoleMode tyki hm - = do { lvl <- getTcLevel - ; return (TcTyMode { mode_tyki = tyki - , mode_holes = Just (lvl,hm) }) } - -instance Outputable HoleMode where - ppr HM_Sig = text "HM_Sig" - ppr HM_FamPat = text "HM_FamPat" - ppr HM_VTA = text "HM_VTA" - ppr HM_TyAppPat = text "HM_TyAppPat" - -instance Outputable TcTyMode where - ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm }) - = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma - , ppr hm ]) - -{- -Note [Bidirectional type checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In expressions, whenever we see a polymorphic identifier, say `id`, we are -free to instantiate it with metavariables, knowing that we can always -re-generalize with type-lambdas when necessary. For example: - - rank2 :: (forall a. a -> a) -> () - x = rank2 id - -When checking the body of `x`, we can instantiate `id` with a metavariable. -Then, when we're checking the application of `rank2`, we notice that we really -need a polymorphic `id`, and then re-generalize over the unconstrained -metavariable. - -In types, however, we're not so lucky, because *we cannot re-generalize*! -There is no lambda. So, we must be careful only to instantiate at the last -possible moment, when we're sure we're never going to want the lost polymorphism -again. This is done in calls to tcInstInvisibleTyBinders. - -To implement this behavior, we use bidirectional type checking, where we -explicitly think about whether we know the kind of the type we're checking -or not. Note that there is a difference between not knowing a kind and -knowing a metavariable kind: the metavariables are TauTvs, and cannot become -forall-quantified kinds. Previously (before dependent types), there were -no higher-rank kinds, and so we could instantiate early and be sure that -no types would have polymorphic kinds, and so we could always assume that -the kind of a type was a fresh metavariable. Not so anymore, thus the -need for two algorithms. - -For HsType forms that can never be kind-polymorphic, we implement only the -"down" direction, where we safely assume a metavariable kind. For HsType forms -that *can* be kind-polymorphic, we implement just the "up" (functions with -"infer" in their name) version, as we gain nothing by also implementing the -"down" version. - -Note [Future-proofing the type checker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As discussed in Note [Bidirectional type checking], each HsType form is -handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions -are mutually recursive, so that either one can work for any type former. -But, we want to make sure that our pattern-matches are complete. So, -we have a bunch of repetitive code just so that we get warnings if we're -missing any patterns. - --} - ------------------------------------------- --- | Check and desugar a type, returning the core type and its --- possibly-polymorphic kind. Much like 'tcInferRho' at the expression --- level. -tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpanA span $ - tc_infer_hs_type mode ty - ---------------------------- --- | Call 'tc_infer_hs_type' and check its result against an expected kind. -tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType -tc_infer_hs_type_ek mode hs_ty ek - = do { (ty, k) <- tc_infer_hs_type mode hs_ty - ; checkExpectedKind hs_ty ty k ek } - ---------------------------- --- | Infer the kind of a type and desugar. This is the "up" type-checker, --- as described in Note [Bidirectional type checking] -tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) - -tc_infer_hs_type mode (HsParTy _ t) - = tc_infer_lhs_type mode t - -tc_infer_hs_type mode ty - | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty - = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty - ; tcInferTyApps mode hs_fun_ty fun_ty hs_args } - -tc_infer_hs_type mode (HsKindSig _ ty sig) - = do { let mode' = mode { mode_tyki = KindLevel } - ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig - -- We must typecheck the kind signature, and solve all - -- its equalities etc; from this point on we may do - -- things like instantiate its foralls, so it needs - -- to be fully determined (#14904) - ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') - ; ty' <- tc_lhs_type mode ty sig' - ; return (ty', sig') } - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate --- the splice location to the typechecker. Here we skip over it in order to have --- the same kind inferred for a given expression whether it was produced from --- splices or not. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) - = tc_infer_hs_type mode ty - -tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty - --- See Note [Typechecking HsCoreTys] -tc_infer_hs_type _ (XHsType ty) - = do env <- getLclEnv - -- Raw uniques since we go from NameEnv to TvSubstEnv. - let subst_prs :: [(Unique, TcTyVar)] - subst_prs = [ (getUnique nm, tv) - | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] - subst = mkTvSubst - (mkInScopeSet $ mkVarSet $ map snd subst_prs) - (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) - ty' = substTy subst ty - return (ty', tcTypeKind ty') - -tc_infer_hs_type _ (HsExplicitListTy _ _ tys) - | null tys -- this is so that we can use visible kind application with '[] - -- e.g ... '[] @Bool - = return (mkTyConTy promotedNilDataCon, - mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) - -tc_infer_hs_type mode other_ty - = do { kv <- newMetaKindVar - ; ty' <- tc_hs_type mode other_ty kv - ; return (ty', kv) } - -{- -Note [Typechecking HsCoreTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. -As such, there's not much to be done in order to typecheck an HsCoreTy, -since it's already been typechecked to some extent. There is one thing that -we must do, however: we must substitute the type variables from the tcl_env. -To see why, consider GeneralizedNewtypeDeriving, which is one of the main -clients of HsCoreTy (example adapted from #14579): - - newtype T a = MkT a deriving newtype Eq - -This will produce an InstInfo GhcPs that looks roughly like this: - - instance forall a_1. Eq a_1 => Eq (T a_1) where - (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an HsCoreTy - @(T a_1 -> T a_1 -> Bool) -- So is this - (==) - -This is then fed into the renamer. Since all of the type variables in this -InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically -identical. Things get more interesting when the InstInfo is fed into the -typechecker, however. GHC will first generate fresh skolems to instantiate -the instance-bound type variables with. In the example above, we might generate -the skolem a_2 and use that to instantiate a_1, which extends the local type -environment (tcl_env) with [a_1 :-> a_2]. This gives us: - - instance forall a_2. Eq a_2 => Eq (T a_2) where ... - -To ensure that the body of this instance is well scoped, every occurrence of -the `a` type variable should refer to a_2, the new skolem. However, the -HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the -substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this -substitution to each HsCoreTy and all is well: - - instance forall a_2. Eq a_2 => Eq (T a_2) where - (==) = coerce @( a_2 -> a_2 -> Bool) - @(T a_2 -> T a_2 -> Bool) - (==) --} - ------------------------------------------- -tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType -tcLHsType hs_ty exp_kind - = tc_lhs_type typeLevelMode hs_ty exp_kind - -tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType -tc_lhs_type mode (L span ty) exp_kind - = setSrcSpanA span $ - tc_hs_type mode ty exp_kind - -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType --- See Note [Bidirectional type checking] - -tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind -tc_hs_type _ ty@(HsBangTy _ bang _) _ - -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), - -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of - -- bangs are invalid, so fail. (#7210, #14761) - = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - ; case bang of - HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" - HsSrcBang _ _ _ -> bangError "strictness" } -tc_hs_type _ ty@(HsRecTy {}) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Record syntax is illegal here:" <+> ppr ty) - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. --- Here we get rid of it and add the finalizers to the global environment --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind - --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Unexpected type splice:" <+> ppr ty) - ----------- Functions and applications -tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind - = tc_fun_type mode mult ty1 ty2 exp_kind - -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind - | op `hasKey` funTyConKey - = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind - = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ - tc_lhs_type mode ty exp_kind - -- Pass on the mode from the type, to any wildcards - -- in kind signatures on the forall'd variables - -- e.g. f :: _ -> Int -> forall (a :: _). blah - -- Why exp_kind? See Note [Body kind of HsForAllTy] - - -- Do not kind-generalise here! See Note [Kind generalisation] - - ; return (mkForAllTys tv_bndrs ty') } - -tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind - | null (unLoc ctxt) - = tc_lhs_type mode rn_ty exp_kind - - -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind - = do { ctxt' <- tc_hs_context mode ctxt - ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - ; ek <- newOpenTypeKind -- The body kind (result of the function) can - -- be TYPE r, for any r, hence newOpenTypeKind - ; ty' <- tc_lhs_type mode rn_ty ek - ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') - liftedTypeKind exp_kind } - ---------- Lists, arrays, and tuples -tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind - = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind - ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in GHC.Hs.Type --- See Note [Inferring tuple kinds] -tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind - -- (NB: not zonking before looking at exp_k, to avoid left-right bias) - | Just tup_sort <- tupKindSort_maybe exp_kind - = traceTc "tc_hs_type tuple" (ppr hs_tys) >> - tc_tuple rn_ty mode tup_sort hs_tys exp_kind - | otherwise - = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) - ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys - ; kinds <- mapM zonkTcType kinds - -- Infer each arg type separately, because errors can be - -- confusing if we give them a shared kind. Eg #7410 - -- (Either Int, Int), we do not want to get an error saying - -- "the second argument of a tuple should have kind *->*" - - ; let (arg_kind, tup_sort) - = case [ (k,s) | k <- kinds - , Just s <- [tupKindSort_maybe k] ] of - ((k,s) : _) -> (k,s) - [] -> (liftedTypeKind, BoxedTuple) - -- In the [] case, it's not clear what the kind is, so guess * - - ; tys' <- sequence [ setSrcSpanA loc $ - checkExpectedKind hs_ty ty kind arg_kind - | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] - - ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } - - -tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind - = tc_tuple rn_ty mode UnboxedTuple tys exp_kind - -tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind - = do { let arity = length hs_tys - ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys - ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds - ; let arg_reps = map kindRep arg_kinds - arg_tys = arg_reps ++ tau_tys - sum_ty = mkTyConApp (sumTyCon arity) arg_tys - sum_kind = unboxedSumKind arg_reps - ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind - } - ---------- Promoted lists and tuples -tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind - = do { tks <- mapM (tc_infer_lhs_type mode) tys - ; (taus', kind) <- unifyKinds tys tks - ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } - where - mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] - mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] - -tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind - -- using newMetaKindVar means that we force instantiations of any polykinded - -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. - = do { ks <- replicateM arity newMetaKindVar - ; taus <- zipWithM (tc_lhs_type mode) tys ks - ; let kind_con = tupleTyCon Boxed arity - ty_con = promotedTupleDataCon Boxed arity - tup_k = mkTyConApp kind_con ks - ; checkTupSize arity - ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind - = do { massert (isTypeLevel (mode_tyki mode)) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind - -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to - -- handle it in 'coreView' and 'tcView'. - = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind - ---------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon naturalTyCon - ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind } - -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind - = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } -tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind - = do { checkWiredInTyCon charTyCon - ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind } - ---------- Wildcards - -tc_hs_type mode ty@(HsWildCardTy _) ek - = tcAnonWildCardOcc NoExtraConstraint mode ty ek - ---------- Potentially kind-polymorphic types: call the "up" checker --- See Note [Future-proofing the type checker] -tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type mode ty@(XHsType {}) ek = tc_infer_hs_type_ek mode ty ek - -{- -Note [Variable Specificity and Forall Visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall -binder. Furthermore, each invisible type variable binder also has a -Specificity. Together, these determine the variable binders (ArgFlag) for each -variable in the generated ForAllTy type. - -This table summarises this relation: ----------------------------------------------------------------------------- -| User-written type HsForAllTelescope Specificity ArgFlag -|--------------------------------------------------------------------------- -| f :: forall a. type HsForAllInvis SpecifiedSpec Specified -| f :: forall {a}. type HsForAllInvis InferredSpec Inferred -| f :: forall a -> type HsForAllVis SpecifiedSpec Required -| f :: forall {a} -> type HsForAllVis InferredSpec / -| This last form is non-sensical and is thus rejected. ----------------------------------------------------------------------------- - -For more information regarding the interpretation of the resulting ArgFlag, see -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". --} - ------------------------------------------- -tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult -tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy ------------------------------------------- -tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind - -> TcM TcType -tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of - TypeLevel -> - do { arg_k <- newOpenTypeKind - ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k - ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') - liftedTypeKind exp_kind } - KindLevel -> -- no representation polymorphism in kinds. yet. - do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind - ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') - liftedTypeKind exp_kind } - -{- Note [Skolem escape and forall-types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Checking telescopes]. - -Consider - f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () - -The Proxy '[a,b] forces a and b to have the same kind. But a's -kind must be bound outside the 'forall a', and hence escapes. -We discover this by building an implication constraint for -each forall. So the inner implication constraint will look like - forall kb (b::kb). kb ~ ka -where ka is a's kind. We can't unify these two, /even/ if ka is -unification variable, because it would be untouchable inside -this inner implication. - -That's what the pushLevelAndCaptureConstraints, plus subsequent -buildTvImplication/emitImplication is all about, when kind-checking -HsForAllTy. - -Note that - -* We don't need to /simplify/ the constraints here - because we aren't generalising. We just capture them. - -* We can't use emitResidualTvConstraint, because that has a fast-path - for empty constraints. We can't take that fast path here, because - we must do the bad-telescope check even if there are no inner wanted - constraints. See Note [Checking telescopes] in - GHC.Tc.Types.Constraint. Lacking this check led to #16247. --} - -{- ********************************************************************* -* * - Tuples -* * -********************************************************************* -} - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType -tc_tuple rn_ty mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (replicate arity liftedTypeKind) - UnboxedTuple -> replicateM arity newOpenTypeKind - ConstraintTuple -> return (replicate arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: HsType GhcRn - -> TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do - traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) - case tup_sort of - ConstraintTuple - | [tau_ty] <- tau_tys - -- Drop any uses of 1-tuple constraints here. - -- See Note [Ignore unary constraint tuples] - -> check_expected_kind tau_ty constraintKind - | otherwise - -> do let tycon = cTupleTyCon arity - checkCTupSize arity - check_expected_kind (mkTyConApp tycon tau_tys) constraintKind - BoxedTuple -> do - let tycon = tupleTyCon Boxed arity - checkTupSize arity - checkWiredInTyCon tycon - check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind - UnboxedTuple -> do - let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds - -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - arg_tys = tau_reps ++ tau_tys - res_kind = unboxedTupleKind tau_reps - checkTupSize arity - check_expected_kind (mkTyConApp tycon arg_tys) res_kind - where - arity = length tau_tys - check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind - -{- -Note [Ignore unary constraint tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in -GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, -recall the definition of a unary tuple data type: - - data Solo a = Solo a - -Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and -lazy. Therefore, the presence of `Solo` matters semantically. On the other -hand, suppose we had a unary constraint tuple: - - class a => Solo% a - -This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is -semantically equivalent to `a`. Therefore, a 1-tuple constraint would have -no user-visible impact, nor would it allow you to express anything that -you couldn't otherwise. - -We could simply add Solo% for consistency with tuples (Solo) and unboxed -tuples (Solo#), but that would require even more magic to wire in another -magical class, so we opt not to do so. We must be careful, however, since -one can try to sneak in uses of unary constraint tuples through Template -Haskell, such as in this program (from #17511): - - f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] - (ConT ''String))) - -- f :: Solo% (Show Int) => String - f = "abc" - -This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, -and since it is used in a Constraint position, GHC will attempt to treat -it as thought it were a constraint tuple, which can potentially lead to -trouble if one attempts to look up the name of a constraint tuple of arity -1 (as it won't exist). To avoid this trouble, we simply take any unary -constraint tuples discovered when typechecking and drop them—i.e., treat -"Solo% a" as though the user had written "a". This is always safe to do -since the two constraints should be semantically equivalent. --} - -{- ********************************************************************* -* * - Type applications -* * -********************************************************************* -} - -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) -splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLocA hs_ty) []) - | otherwise = Nothing - where - is_app :: HsType GhcRn -> Bool - is_app (HsAppKindTy {}) = True - is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) - -- I'm not sure why this funTyConKey test is necessary - -- Can it even happen? Perhaps for t1 `(->)` t2 - -- but then maybe it's ok to treat that like a normal - -- application rather than using the special rule for HsFunTy - is_app (HsTyVar {}) = True - is_app (HsParTy _ (L _ ty)) = is_app ty - is_app _ = False - - go :: LHsType GhcRn - -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] - -> (LHsType GhcRn, - [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) - go (L _ (HsOpTy _ l op@(L sp _) r)) as - = ( L (na2la sp) (HsTyVar noAnn NotPromoted op) - , HsValArg l : HsValArg r : as ) - go f as = (f, as) - ---------------------------- -tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) --- Version of tc_infer_lhs_type specialised for the head of an --- application. In particular, for a HsTyVar (which includes type --- constructors, it does not zoom off into tcInferTyApps and family --- saturation -tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv))) - = tcTyVar mode tv -tcInferTyAppHead mode ty - = tc_infer_lhs_type mode ty - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. Always consumes all the arguments, --- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- --- These kinds should be used to instantiate invisible kind variables; --- they come from an enclosing class for an associated type/data family. --- --- tcInferTyApps also arranges to saturate any trailing invisible arguments --- of a type-family application, which is usually the right thing to do --- tcInferTyApps_nosat does not do this saturation; it is used only --- by ":kind" in GHCi -tcInferTyApps, tcInferTyApps_nosat - :: TcTyMode - -> LHsType GhcRn -- ^ Function (for printing only) - -> TcType -- ^ Function - -> [LHsTypeArg GhcRn] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -tcInferTyApps mode hs_ty fun hs_args - = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args - ; saturateFamApp f_args res_k } - -tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args - = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) - ; (f_args, res_k) <- go_init 1 fun orig_hs_args - ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) - ; return (f_args, res_k) } - where - - -- go_init just initialises the auxiliary - -- arguments of the 'go' loop - go_init n fun all_args - = go n fun empty_subst fun_ki all_args - where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller - -- knows the function kind, to absolutely guarantee - -- INVARIANT for 'go' - -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so tcTypeKind is fast - - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfType fun_ki - - go :: Int -- The # of the next argument - -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind - -> TcKind -- Function kind - -> [LHsTypeArg GhcRn] -- Un-type-checked args - -> TcM (TcType, TcKind) -- Result type and its kind - -- INVARIANT: in any call (go n fun subst fun_ki args) - -- tcTypeKind fun = subst(fun_ki) - -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. - -- - -- Reason for INVARIANT: to support the Purely Kinded Type Invariant - -- it's important that if fun_ki has a forall, then so does - -- (tcTypeKind fun), because the next thing we are going to do - -- is apply 'fun' to an argument type. - - -- Dispatch on all_args first, for performance reasons - go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of - - ---------------- No user-written args left. We're done! - ([], _) -> return (fun, substTy subst fun_ki) - - ---------------- HsArgPar: We don't care about parens here - (HsArgPar _ : args, _) -> go n fun subst fun_ki args - - ---------------- HsTypeArg: a kind application (fun @ki) - (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> - case ki_binder of - - -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki - - Named (Bndr _ Specified) -> -- Visible kind application - do { traceTc "tcInferTyApps (vis kind app)" - (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - - ; let exp_kind = substTy subst $ tyBinderType ki_binder - ; arg_mode <- mkHoleMode KindLevel HM_VTA - -- HM_VKA: see Note [Wildcards in visible kind application] - ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ - tc_lhs_type arg_mode hs_ki_arg exp_kind - - ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg - ; go (n+1) fun' subst' inner_ki hs_args } - - -- Attempted visible kind application (fun @ki), but fun_ki is - -- forall k -> blah or k1 -> k2 - -- So we need a normal application. Error. - _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki - - -- No binder; try applying the substitution, or fail if that's not possible - (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ - ty_app_err ki_arg substed_fun_ki - - ---------------- HsValArg: a normal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) - -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder inner_ki - - -- "normal" case - | otherwise - -> do { traceTc "tcInferTyApps (vis normal app)" - (vcat [ ppr ki_binder - , ppr arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder - ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ - tc_lhs_type mode arg exp_kind - ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind) - ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' - ; go (n+1) fun' subst' inner_ki args } - - -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) - -> try_again_after_substing_or $ - do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki - - ; fun' <- zonkTcType (fun `mkTcCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop - - ; traceTc "tcInferTyApps (no binder)" $ - vcat [ ppr fun <+> dcolon <+> ppr fun_ki - , ppr arrows_needed - , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT - where - instantiate ki_binder inner_ki - = do { traceTc "tcInferTyApps (need to instantiate)" - (vcat [ ppr ki_binder, ppr subst]) - ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder - ; go n (mkAppTy fun arg') subst' inner_ki all_args } - -- Because tcInvisibleTyBinder instantiate ki_binder, - -- the kind of arg' will have the same shape as the kind - -- of ki_binder. So we don't need mkAppTyM here. - - try_again_after_substing_or fallthrough - | not (isEmptyTCvSubst subst) - = go n fun zapped_subst substed_fun_ki all_args - | otherwise - = fallthrough - - zapped_subst = zapTCvSubst subst - substed_fun_ki = substTy subst fun_ki - hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - - n_initial_val_args :: [HsArg tm ty] -> Arity - -- Count how many leading HsValArgs we have - n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args - n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args - n_initial_val_args _ = 0 - - ty_app_err arg ty - = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - - -mkAppTyM :: TCvSubst - -> TcType -> TyCoBinder -- fun, plus its top-level binder - -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) --- Precondition: the application (fun arg) is well-kinded after zonking --- That is, the application makes sense --- --- Precondition: for (mkAppTyM subst fun bndr arg) --- tcTypeKind fun = Pi bndr. body --- That is, fun always has a ForAllTy or FunTy at the top --- and 'bndr' is fun's pi-binder --- --- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type --- invariant, then so does the result type (fun arg) --- --- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) --- This must be true after zonking (precondition 1), but it's not --- required for the (PKTI). -mkAppTyM subst fun ki_binder arg - | -- See Note [mkAppTyM]: Nasty case 2 - TyConApp tc args <- fun - , isTypeSynonymTyCon tc - , args `lengthIs` (tyConArity tc - 1) - , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym - = do { arg' <- zonkTcType arg - ; args' <- zonkTcTypes args - ; let subst' = case ki_binder of - Anon {} -> subst - Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' - ; return (subst', mkTyConApp tc (args' ++ [arg'])) } - - -mkAppTyM subst fun (Anon {}) arg - = return (subst, mk_app_ty fun arg) - -mkAppTyM subst fun (Named (Bndr tv _)) arg - = do { arg' <- if isTrickyTvBinder tv - then -- See Note [mkAppTyM]: Nasty case 1 - zonkTcType arg - else return arg - ; return ( extendTvSubstAndInScope subst tv arg' - , mk_app_ty fun arg' ) } - -mk_app_ty :: TcType -> TcType -> TcType --- This function just adds an ASSERT for mkAppTyM's precondition -mk_app_ty fun arg - = assertPpr (isPiTy fun_kind) - (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ - mkAppTy fun arg - where - fun_kind = tcTypeKind fun - -isTrickyTvBinder :: TcTyVar -> Bool --- NB: isTrickyTvBinder is just an optimisation --- It would be absolutely sound to return True always -isTrickyTvBinder tv = isPiTy (tyVarKind tv) - -{- Note [The Purely Kinded Type Invariant (PKTI)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type inference, we maintain this invariant - - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, - on any sub-term of ty, /without/ zonking ty - - Moreover, any such returned kind - will itself satisfy (PKTI) - -By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications - (a t1 t2 .. tn) -if 'a' is a type variable whose kind doesn't have enough arrows -or foralls. (The crash is in piResultTys.) - -The loop in tcInferTyApps has to be very careful to maintain the (PKTI). -For example, suppose - kappa is a unification variable - We have already unified kappa := Type - yielding co :: Refl (Type -> Type) - a :: kappa -then consider the type - (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) -kind of 'a' is just kappa, not an arrow kind. So we must zonk first. - -So the type inference engine is very careful when building applications. -This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), -where (a :: kappa). Then in tcInferApps we'll run out of binders on -a's kind, so we'll call matchExpectedFunKind, and unify - kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) -At this point we must zonk the function type to expose the arrrow, so -that (a Int) will satisfy (PKTI). - -The absence of this caused #14174 and #14520. - -The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. - -Wrinkle around FunTy: -Note that the PKTI does *not* guarantee anything about the shape of FunTys. -Specifically, when we have (FunTy vis mult arg res), it should be the case -that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we -might not have this. Example: if the user writes (a -> b), then we might -invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1 -(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2). -However, when we build the FunTy, we might not have zonked `a`, and so the -FunTy will be built without being able to purely extract the RuntimeReps. - -Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, -we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* -split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] -in GHC.Tc.Solver.Canonical. - -Note [mkAppTyM] -~~~~~~~~~~~~~~~ -mkAppTyM is trying to guarantee the Purely Kinded Type Invariant -(PKTI) for its result type (fun arg). There are two ways it can go wrong: - -* Nasty case 1: forall types (polykinds/T14174a) - T :: forall (p :: *->*). p Int -> p Bool - Now kind-check (T x), where x::kappa. - Well, T and x both satisfy the PKTI, but - T x :: x Int -> x Bool - and (x Int) does /not/ satisfy the PKTI. - -* Nasty case 2: type synonyms - type S f a = f a - Even though (S ff aa) would satisfy the (PKTI) if S was a data type - (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) - if S is a type synonym, because the /expansion/ of (S ff aa) is - (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps - (ff :: kappa), where 'kappa' has already been unified with (*->*). - - We check for nasty case 2 on the final argument of a type synonym. - -Notice that in both cases the trickiness only happens if the -bound variable has a pi-type. Hence isTrickyTvBinder. --} - - -saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) --- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind --- --- If 'ty' is an unsaturated family application with trailing --- invisible arguments, instantiate them. --- See Note [saturateFamApp] - -saturateFamApp ty kind - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc - , let n_to_inst = tyConArity tc - length args - = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } - | otherwise - = return (ty, kind) - -{- Note [saturateFamApp] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: Either j k - type instance F @Type = Right Maybe - type instance F @Type = Right Either``` - -Then F :: forall {j,k}. Either j k - -The two type instances do a visible kind application that instantiates -'j' but not 'k'. But we want to end up with instances that look like - type instance F @Type @(*->*) = Right @Type @(*->*) Maybe - -so that F has arity 2. We must instantiate that trailing invisible -binder. In general, Invisible binders precede Specified and Required, -so this is only going to bite for apparently-nullary families. - -Note that - type family F2 :: forall k. k -> * -is quite different and really does have arity 0. - -It's not just type instances where we need to saturate those -unsaturated arguments: see #11246. Hence doing this in tcInferApps. --} - -appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn -appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg l arg : args) - = appTypeToArg (mkHsAppKindTy l f arg) args - - -{- ********************************************************************* -* * - checkExpectedKind -* * -********************************************************************* -} - --- | This instantiates invisible arguments for the type being checked if it must --- be saturated and is not yet saturated. It then calls and uses the result --- from checkExpectedKindX to build the final type -checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- ^ type we're checking (for printing) - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType --- Just a convenience wrapper to save calls to 'ppr' -checkExpectedKind hs_ty ty act_kind exp_kind - = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) - - ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just (ppr hs_ty) - , uo_visible = True } -- the hs_ty is visible - - ; traceTc "checkExpectedKindX" $ - vcat [ ppr hs_ty - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; let res_ty = ty `mkTcAppTys` new_args - - ; if act_kind' `tcEqType` exp_kind - then return res_ty -- This is very common - else do { co_k <- uType KindLevel origin act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; return (res_ty `mkTcCastTy` co_k) } } - where - -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - ---------------------------- - -tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsContext Nothing = return [] -tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt - -tcLHsPredType :: LHsType GhcRn -> TcM PredType -tcLHsPredType pred = tc_lhs_pred typeLevelMode pred - -tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in GHC.Tc.TyCl --- This does not instantiate. See Note [Do not always instantiate eagerly in types] -tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - -- See Note [Recursion through the kinds] - ATcTyCon tc_tc - -> do { check_tc tc_tc - ; return (mkTyConTy tc_tc, tyConKind tc_tc) } - - AGlobal (ATyCon tc) - -> do { check_tc tc - ; return (mkTyConTy tc, tyConKind tc) } - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; when (isFamInstTyCon (dataConTyCon dc)) $ - -- see #15245 - promotionErr name FamDataConPE - ; let (_, _, _, theta, _, _) = dataConFullSig dc - ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) - ; case dc_theta_illegal_constraint theta of - Just pred -> promotionErr name $ - ConstrainedDataConPE pred - Nothing -> pure () - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - check_tc :: TyCon -> TcM () - check_tc tc = do { data_kinds <- xoptM LangExt.DataKinds - ; unless (isTypeLevel (mode_tyki mode) || - data_kinds || - isKindTyCon tc) $ - promotionErr name NoDataKindsTC } - - -- We cannot promote a data constructor with a context that contains - -- constraints other than equalities, so error if we find one. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - dc_theta_illegal_constraint :: ThetaType -> Maybe PredType - dc_theta_illegal_constraint = find (not . isEqPred) - -{- -Note [Recursion through the kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these examples - -Ticket #11554: - data P (x :: k) = Q - data A :: Type where - MkA :: forall (a :: A). P a -> A - -Ticket #12174 - data V a - data T = forall (a :: T). MkT (V a) - -The type is recursive (which is fine) but it is recursive /through the -kinds/. In earlier versions of GHC this caused a loop in the compiler -(to do with knot-tying) but there is nothing fundamentally wrong with -the code (kinds are types, and the recursive declarations are OK). But -it's hard to distinguish "recursion through the kinds" from "recursion -through the types". Consider this (also #11554): - - data PB k (x :: k) = Q - data B :: Type where - MkB :: P B a -> B - -Here the occurrence of B is not obviously in a kind position. - -So now GHC allows all these programs. #12081 and #15942 are other -examples. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see -typecheck/should_compile/tc170). - -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is either * or #. But this is -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for * or # here. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-kind of the HsQualTy is Constraint rather than *. -Rather crudely we tell the difference by looking at exp_kind. It's -very convenient to typecheck instance types like any other HsSigType. - -Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's -better to reject in checkValidType. If we say that the body kind -should be '*' we risk getting TWO error messages, one saying that Eq -[a] doesn't have kind '*', and one saying that we need a Constraint to -the left of the outer (=>). - -How do we figure out the right body kind? Well, it's a bit of a -kludge: I just look at the expected kind. If it's Constraint, we -must be in this instance situation context. It's a kludge because it -wouldn't work if any unification was involved to compute that result -kind -- but it isn't. (The true way might be to use the 'mode' -parameter, but that seemed like a sledgehammer to crack a nut.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the arguments to give good error messages in - e.g. (Maybe, Maybe) - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * It zonks any kinds. The returned type should have no mutable kind - or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to (Any *) just - as in GHC.Tc.Utils.Zonk. - - there are no mutable type variables because we are - kind-checking a type - Reason: the returned type may be put in a TyCon or DataCon where - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - --} - -addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisible ones and ones user's won't grok -addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - - -{- ********************************************************************* -* * - Type-variable binders -* * -********************************************************************* -} - -bindNamedWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a --- Bring into scope the /named/ wildcard binders. Remember that --- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Type -bindNamedWildCardBinders wc_names thing_inside - = do { wcs <- mapM newNamedWildTyVar wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendNameTyVarEnv wc_prs $ - thing_inside wc_prs } - -newNamedWildTyVar :: Name -> TcM TcTyVar --- ^ New unification variable '_' for a wildcard -newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type - = do { kind <- newMetaKindVar - ; details <- newMetaDetails TauTv - ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names] - ; let tyvar = mkTcTyVar wc_name kind details - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } - ---------------------------- -tcAnonWildCardOcc :: IsExtraConstraint - -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) - ty exp_kind - -- hole_lvl: see Note [Checking partial type signatures] - -- esp the bullet on nested forall types - = do { kv_details <- newTauTvDetailsAtLevel hole_lvl - ; kv_name <- newMetaTyVarName (fsLit "k") - ; wc_details <- newTauTvDetailsAtLevel hole_lvl - ; wc_name <- newMetaTyVarName (fsLit wc_nm) - ; let kv = mkTcTyVar kv_name liftedTypeKind kv_details - wc_kind = mkTyVarTy kv - wc_tv = mkTcTyVar wc_name wc_kind wc_details - - ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) - ; when emit_holes $ - emitAnonTypeHole is_extra wc_tv - -- Why the 'when' guard? - -- See Note [Wildcards in visible kind application] - - -- You might think that this would always just unify - -- wc_kind with exp_kind, so we could avoid even creating kv - -- But the level numbers might not allow that unification, - -- so we have to do it properly (T14140a) - ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind } - where - -- See Note [Wildcard names] - wc_nm = case hole_mode of - HM_Sig -> "w" - HM_FamPat -> "_" - HM_VTA -> "w" - HM_TyAppPat -> "_" - - emit_holes = case hole_mode of - HM_Sig -> True - HM_FamPat -> False - HM_VTA -> False - HM_TyAppPat -> False - -tcAnonWildCardOcc _ mode ty _ --- mode_holes is Nothing. Should not happen, because renamer --- should already have rejected holes in unexpected places - = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty) - -{- Note [Wildcard names] -~~~~~~~~~~~~~~~~~~~~~~~~ -So we hackily use the mode_holes flag to control the name used -for wildcards: - -* For proper holes (whether in a visible type application (VTA) or no), - we rename the '_' to 'w'. This is so that we see variables like 'w0' - or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For - example, we prefer - Found type wildcard ‘_’ standing for ‘w0’ - over - Found type wildcard ‘_’ standing for ‘_1’ - - Even in the VTA case, where we do not emit an error to be printed, we - want to do the renaming, as the variables may appear in other, - non-wildcard error messages. - -* However, holes in the left-hand sides of type families ("type - patterns") stand for type variables which we do not care to name -- - much like the use of an underscore in an ordinary term-level - pattern. When we spot these, we neither wish to generate an error - message nor to rename the variable. We don't rename the variable so - that we can pretty-print a type family LHS as, e.g., - F _ Int _ = ... - and not - F w1 Int w2 = ... - - See also Note [Wildcards in family instances] in - GHC.Rename.Module. The choice of HM_FamPat is made in - tcFamTyPats. There is also some unsavory magic, relying on that - underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. - -Note [Wildcards in visible kind application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are cases where users might want to pass in a wildcard as a visible kind -argument, for instance: - -data T :: forall k1 k2. k1 → k2 → Type where - MkT :: T a b -x :: T @_ @Nat False n -x = MkT - -So we should allow '@_' without emitting any hole constraints, and -regardless of whether PartialTypeSignatures is enabled or not. But how -would the typechecker know which '_' is being used in VKA and which is -not when it calls emitNamedTypeHole in -tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither -rename nor include unnamed wildcards in HsWildCardBndrs, but instead -give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. - -And whenever we see a '@', we set mode_holes to HM_VKA, so that -we do not call emitAnonTypeHole in tcAnonWildCardOcc. -See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Type --} - -{- ********************************************************************* -* * - Kind inference for type declarations -* * -********************************************************************* -} - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -data InitialKindStrategy - = InitialKindCheck SAKS_or_CUSK - | InitialKindInfer - --- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-specified kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified kind (CUSK) - -instance Outputable SAKS_or_CUSK where - ppr (SAKS k) = text "SAKS" <+> ppr k - ppr CUSK = text "CUSK" - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -kcDeclHeader - :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig -kcDeclHeader InitialKindInfer = kcInferDeclHeader - -{- Note [kcCheckDeclHeader vs kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind -of a type constructor. - -* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that - case, find the full, final, poly-kinded kind of the TyCon. It's very like a - term-level binding where we have a complete type signature for the function. - -* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a - CUSK. Find a monomorphic kind, with unification variables in it; they will be - generalised later. It's very like a term-level binding where we do not have a - type signature (or, more accurately, where we have a partial type signature), - so we infer the type and generalise. --} - ------------------------------- -kcCheckDeclHeader - :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig -kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk - -kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader_cusk name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- CUSK case - -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - = addTyConFlavCtxt name flav $ - do { (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ - bindImplicitTKBndrs_Q_Skol kv_ns $ - bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - - -- Now, because we're in a CUSK, - -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ tc_tvs - all_kinds = res_kind : map tyVarKind spec_req_tkvs - - ; candidates' <- candidateQTyVarsOfKinds all_kinds - -- 'candidates' are all the variables that we are going to - -- skolemise and then quantify over. We do not include spec_req_tvs - -- because they are /already/ skolems - - ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds)) - candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates } - inf_candidates = candidates `delCandidates` spec_req_tkvs - - ; inferred <- quantifyTyVars DefaultNonStandardTyVars inf_candidates - -- NB: 'inferred' comes back sorted in dependency order - - ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs - ; res_kind <- zonkTcType res_kind - - ; let mentioned_kv_set = candidateKindVars candidates - specified = scopedSort scoped_kvs - -- NB: maintain the L-R order of scoped_kvs - - final_tc_binders = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs - True -- it is generalised - flav - - ; reportUnsolvedEqualities skol_info (binderVars final_tc_binders) - tclvl wanted - - -- If the ordering from - -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - -- doesn't work, we catch it here, before an error cascade - ; checkTyConTelescope tycon - - ; traceTc "kcCheckDeclHeader_cusk " $ - vcat [ text "name" <+> ppr name - , text "kv_ns" <+> ppr kv_ns - , text "hs_tvs" <+> ppr hs_tvs - , text "scoped_kvs" <+> ppr scoped_kvs - , text "tc_tvs" <+> ppr tc_tvs - , text "res_kind" <+> ppr res_kind - , text "candidates" <+> ppr candidates - , text "inferred" <+> ppr inferred - , text "specified" <+> ppr specified - , text "final_tc_binders" <+> ppr final_tc_binders - , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tc_binders res_kind) - , text "all_tv_prs" <+> ppr all_tv_prs ] - - ; return tycon } - where - skol_info = TyConSkol flav name - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - --- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and --- other kinds). --- --- This function does not do telescope checking. -kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded non-generalized TcTyCon -kcInferDeclHeader name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- No standalane kind signature and no CUSK. - -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - = addTyConFlavCtxt name flav $ - do { (scoped_kvs, (tc_tvs, res_kind)) - -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - -- Why "_Tv" not "_Skol"? See third wrinkle in - -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, - - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- might unify with kind vars in other types in a mutually - -- recursive group. - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - - tc_binders = mkAnonTyConBinders VisArg tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in GHC.Tc.TyCl - -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - -- NB: bindExplicitTKBndrs_Q_Tv does not clone; - -- ditto Implicit - -- See Note [Cloning for type variable binders] - - tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- not yet generalised - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - --- | Kind-check a declaration header against a standalone kind signature. --- See Note [Arity inference in kcCheckDeclHeader_sig] -kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcCheckDeclHeader_sig kisig name flav - (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = explicit_nms }) kc_res_ki - = addTyConFlavCtxt name flav $ - do { -- Step 1: zip user-written binders with quantifiers from the kind signature. - -- For example: - -- - -- type F :: forall k -> k -> forall j. j -> Type - -- data F i a b = ... - -- - -- Results in the following 'zipped_binders': - -- - -- TyBinder LHsTyVarBndr - -- --------------------------------------- - -- ZippedBinder forall k -> i - -- ZippedBinder k -> a - -- ZippedBinder forall j. - -- ZippedBinder j -> b - -- - let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms - - -- Report binders that don't have a corresponding quantifier. - -- For example: - -- - -- type T :: Type -> Type - -- data T b1 b2 b3 = ... - -- - -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders. - -- - ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs) - - -- Convert each ZippedBinder to TyConBinder for tyConBinders - -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars - ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - - ; (tclvl, wanted, (implicit_tvs, (invis_binders, r_ki))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 - bindImplicitTKBndrs_Tv implicit_nms $ - tcExtendNameTyVarEnv explicit_tv_prs $ - do { -- Check that inline kind annotations on binders are valid. - -- For example: - -- - -- type T :: Maybe k -> Type - -- data T (a :: Maybe j) = ... - -- - -- Here we unify Maybe k ~ Maybe j - mapM_ check_zipped_binder zipped_binders - - -- Kind-check the result kind annotation, if present: - -- - -- data T a b :: res_ki where - -- ^^^^^^^^^ - -- We do it here because at this point the environment has been - -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; ctx_k <- kc_res_ki - ; m_res_ki <- case ctx_k of - AnyKind -> return Nothing - _ -> Just <$> newExpectedKind ctx_k - - -- Step 2: split off invisible binders. - -- For example: - -- - -- type F :: forall k1 k2. (k1, k2) -> Type - -- type family F - -- - -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'? - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki - - -- Check that the inline result kind annotation is valid. - -- For example: - -- - -- type T :: Type -> Maybe k - -- type family T a :: Maybe j where - -- - -- Here we unify Maybe k ~ Maybe j - ; whenIsJust m_res_ki $ \res_ki -> - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind Nothing r_ki res_ki - - ; return (invis_binders, r_ki) } - - -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders. - ; invis_tcbs <- mapM invis_to_tcb invis_binders - - -- Zonk the implicitly quantified variables. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - - -- Build the final, generalized TcTyCon - ; let tcbs = vis_tcbs ++ invis_tcbs - implicit_tv_prs = implicit_nms `zip` implicit_tvs - all_tv_prs = implicit_tv_prs ++ explicit_tv_prs - tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav - skol_info = TyConSkol flav name - - -- Check that there are no unsolved equalities - ; reportUnsolvedEqualities skol_info (binderVars tcbs) tclvl wanted - - ; traceTc "kcCheckDeclHeader_sig done:" $ vcat - [ text "tyConName = " <+> ppr (tyConName tc) - , text "kisig =" <+> debugPprType kisig - , text "tyConKind =" <+> debugPprType (tyConKind tc) - , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc) - , text "tyConResKind" <+> debugPprType (tyConResKind tc) - ] - ; return tc } - where - -- Consider this declaration: - -- - -- type T :: forall a. forall b -> (a~b) => Proxy a -> Type - -- data T x p = MkT - -- - -- Here, we have every possible variant of ZippedBinder: - -- - -- TyBinder LHsTyVarBndr - -- ---------------------------------------------- - -- ZippedBinder forall {k}. - -- ZippedBinder forall (a::k). - -- ZippedBinder forall (b::k) -> x - -- ZippedBinder (a~b) => - -- ZippedBinder Proxy a -> p - -- - -- Given a ZippedBinder zipped_to_tcb produces: - -- - -- * TyConBinder for tyConBinders - -- * (Name, TcTyVar) for tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr - -- - zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)]) - zipped_to_tcb zb = case zb of - - -- Inferred variable, no user-written binder. - -- Example: forall {k}. - ZippedBinder (Named (Bndr v Specified)) Nothing -> - return (mkNamedTyConBinder Specified v, []) - - -- Specified variable, no user-written binder. - -- Example: forall (a::k). - ZippedBinder (Named (Bndr v Inferred)) Nothing -> - return (mkNamedTyConBinder Inferred v, []) - - -- Constraint, no user-written binder. - -- Example: (a~b) => - ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do - name <- newSysName (mkTyVarOccFS (fsLit "ev")) - let tv = mkTyVar name (scaledThing bndr_ki) - return (mkAnonTyConBinder InvisArg tv, []) - - -- Non-dependent visible argument with a user-written binder. - -- Example: Proxy a -> - ZippedBinder (Anon VisArg bndr_ki) (Just b) -> - return $ - let v_name = getName b - tv = mkTyVar v_name (scaledThing bndr_ki) - tcb = mkAnonTyConBinder VisArg tv - in (tcb, [(v_name, tv)]) - - -- Dependent visible argument with a user-written binder. - -- Example: forall (b::k) -> - ZippedBinder (Named (Bndr v Required)) (Just b) -> - return $ - let v_name = getName b - tcb = mkNamedTyConBinder Required v - in (tcb, [(v_name, v)]) - - -- 'zipBinders' does not produce any other variants of ZippedBinder. - _ -> panic "goVis: invalid ZippedBinder" - - -- Given an invisible binder that comes from 'split_invis', - -- convert it to TyConBinder. - invis_to_tcb :: TyCoBinder -> TcM TyConBinder - invis_to_tcb tb = do - (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing) - massert (null stv) - return tcb - - -- Check that the inline kind annotation on a binder is valid - -- by unifying it with the kind of the quantifier. - check_zipped_binder :: ZippedBinder -> TcM () - check_zipped_binder (ZippedBinder _ Nothing) = return () - check_zipped_binder (ZippedBinder tb (Just b)) = - case unLoc b of - UserTyVar _ _ _ -> return () - KindedTyVar _ _ v v_hs_ki -> do - v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki - discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (ppr v)) - (tyBinderType tb) - v_ki - - -- Split the invisible binders that should become a part of 'tyConBinders' - -- rather than 'tyConResKind'. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind) - split_invis sig_ki Nothing = - -- instantiate all invisible binders - splitInvisPiTys sig_ki - split_invis sig_ki (Just res_ki) = - -- subtraction a la checkExpectedKind - let n_res_invis_bndrs = invisibleTyBndrCount res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_ki - n_inst = n_sig_invis_bndrs - n_res_invis_bndrs - in splitInvisPiTysN n_inst sig_ki - --- A quantifier from a kind signature zipped with a user-written binder for it. -data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn)) - --- See Note [Arity inference in kcCheckDeclHeader_sig] -zipBinders - :: Kind -- Kind signature - -> [LHsTyVarBndr () GhcRn] -- User-written binders - -> ( [ZippedBinder] -- Zipped binders - , [LHsTyVarBndr () GhcRn] -- Leftover user-written binders - , Kind ) -- Remainder of the kind signature -zipBinders = zip_binders [] emptyTCvSubst - where - -- subst: we substitute as we go, to ensure that the resulting - -- binders in the [ZippedBndr] all have distinct uniques. - -- If not, the TyCon may get multiple binders with the same unique, - -- which results in chaos (see #19092,3,4) - -- (The incoming kind might be forall k. k -> forall k. k -> Type - -- where those two k's have the same unique. Without the substitution - -- we'd get a repeated 'k'.) - zip_binders acc subst ki bs - | (b:bs') <- bs -- Stop as soon as 'bs' becomes empty - , Just (tb,ki') <- tcSplitPiTy_maybe ki - , let (subst', tb') = substTyCoBndr subst tb - = if isInvisibleBinder tb - then zip_binders (ZippedBinder tb' Nothing : acc) subst' ki' bs - else zip_binders (ZippedBinder tb' (Just b) : acc) subst' ki' bs' - - | otherwise - = (reverse acc, bs, substTy subst ki) - -tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage -tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - -{- Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig -verifies that the declaration conforms to the signature. The end result is a -TcTyCon 'tc' such that: - - tyConKind tc == kisig - -This TcTyCon would be rather easy to produce if we didn't have to worry about -arity. Consider these declarations: - - type family S1 :: forall k. k -> Type - type family S2 (a :: k) :: Type - -Both S1 and S2 can be given the same standalone kind signature: - - type S2 :: forall k. k -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from -tyConBinders and tyConResKind, such that - - tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc) - -For S1 and S2, tyConBinders and tyConResKind are different: - - tyConBinders S1 == [] - tyConResKind S1 == forall k. k -> Type - tyConKind S1 == forall k. k -> Type - - tyConBinders S2 == [spec k, anon-vis (a :: k)] - tyConResKind S2 == Type - tyConKind S1 == forall k. k -> Type - -This difference determines the arity: - - tyConArity tc == length (tyConBinders tc) - -That is, the arity of S1 is 0, while the arity of S2 is 2. - -'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone -kind signature into binders and the result kind. It does so in two rounds: - -1. zip user-written binders (vis_tcbs) -2. split off invisible binders (invis_tcbs) - -Consider the following declarations: - - type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family F a b - - type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family G a b :: forall r2. (r1, r2) -> Type - -In step 1 (zip user-written binders), we zip the quantifiers in the signature -with the binders in the header using 'zipBinders'. In both F and G, this results in -the following zipped binders: - - TyBinder LHsTyVarBndr - --------------------------------------- - ZippedBinder Type -> a - ZippedBinder forall j. - ZippedBinder j -> b - - -At this point, we have accumulated three zipped binders which correspond to a -prefix of the standalone kind signature: - - Type -> forall j. j -> ... - -In step 2 (split off invisible binders), we have to decide how much remaining -invisible binders of the standalone kind signature to split off: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split off or not? - -This decision is made in 'split_invis': - -* If a user-written result kind signature is not provided, as in F, - then split off all invisible binders. This is why we need special treatment - for AnyKind. -* If a user-written result kind signature is provided, as in G, - then do as checkExpectedKind does and split off (n_sig - n_res) binders. - That is, split off such an amount of binders that the remainder of the - standalone kind signature and the user-written result kind signature have the - same amount of invisible quantifiers. - -For F, split_invis splits away all invisible binders, and we have 2: - - forall k1 k2. (k1, k2) -> Type - ^^^^^^^^^^^^^ - split away both binders - -The resulting arity of F is 3+2=5. (length vis_tcbs = 3, - length invis_tcbs = 2, - length tcbs = 5) - -For G, split_invis decides to split off 1 invisible binder, so that we have the -same amount of invisible quantifiers left: - - res_ki = forall r2. (r1, r2) -> Type - kisig = forall k1 k2. (k1, k2) -> Type - ^^^ - split off this one. - -The resulting arity of G is 3+1=4. (length vis_tcbs = 3, - length invis_tcbs = 1, - length tcbs = 4) - --} - -{- Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use 'unifyKind' to check inline kind annotations in declaration headers -against the signature. - - type T :: [i] -> Maybe j -> Type - data T (a :: [k1]) (b :: Maybe k2) :: Type where ... - -Here, we will unify: - - [k1] ~ [i] - Maybe k2 ~ Maybe j - Type ~ Type - -The end result is that we fill in unification variables k1, k2: - - k1 := i - k2 := j - -We also validate that the user isn't confused: - - type T :: Type -> Type - data T (a :: Bool) = ... - -This will report that (Type ~ Bool) failed to unify. - -Now, consider the following example: - - type family Id a where Id x = x - type T :: Bool -> Type - type T (a :: Id Bool) = ... - -We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. -However, we are free to discard it, as the kind of 'T' is determined by the -signature, not by the inline kind annotation: - - we have T :: Bool -> Type - rather than T :: Id Bool -> Type - -This (Id Bool) will not show up anywhere after we're done validating it, so we -have no use for the produced coercion. --} - -{- Note [No polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should this kind-check? - data T ka (a::ka) b = MkT (T Type Int Bool) - (T (Type -> Type) Maybe Bool) - -Notice that T is used at two different kinds in its RHS. No! -This should not kind-check. Polymorphic recursion is known to -be a tough nut. - -Previously, we laboriously (with help from the renamer) -tried to give T the polymorphic kind - T :: forall ka -> ka -> kappa -> Type -where kappa is a unification variable, even in the inferInitialKinds -phase (which is what kcInferDeclHeader is all about). But -that is dangerously fragile (see the ticket). - -Solution: make kcInferDeclHeader give T a straightforward -monomorphic kind, with no quantification whatsoever. That's why -we use mkAnonTyConBinder for all arguments when figuring out -tc_binders. - -But notice that (#16322 comment:3) - -* The algorithm successfully kind-checks this declaration: - data T2 ka (a::ka) = MkT2 (T2 Type a) - - Starting with (inferInitialKinds) - T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * - we get - kappa4 := kappa1 -- from the (a:ka) kind signature - kappa1 := Type -- From application T2 Type - - These constraints are soluble so generaliseTcTyCon gives - T2 :: forall (k::Type) -> k -> * - - But now the /typechecking/ (aka desugaring, tcTyClDecl) phase - fails, because the call (T2 Type a) in the RHS is ill-kinded. - - We'd really prefer all errors to show up in the kind checking - phase. - -* This algorithm still accepts (in all phases) - data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) - although T3 is really polymorphic-recursive too. - Perhaps we should somehow reject that. - -Note [Kind variable ordering for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should be the kind of `T` in the following example? (#15591) - - class C (a :: Type) where - type T (x :: f a) - -As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify -the kind variables in left-to-right order of first occurrence in order to -support visible kind application. But we cannot perform this analysis on just -T alone, since its variable `a` actually occurs /before/ `f` if you consider -the fact that `a` was previously bound by the parent class `C`. That is to say, -the kind of `T` should end up being: - - T :: forall a f. f a -> Type - -(It wouldn't necessarily be /wrong/ if the kind ended up being, say, -forall f a. f a -> Type, but that would not be as predictable for users of -visible kind application.) - -In contrast, if `T` were redefined to be a top-level type family, like `T2` -below: - - type family T2 (x :: f (a :: Type)) - -Then `a` first appears /after/ `f`, so the kind of `T2` should be: - - T2 :: forall f a. f a -> Type - -In order to make this distinction, we need to know (in kcCheckDeclHeader) which -type variables have been bound by the parent class (if there is one). With -the class-bound variables in hand, we can ensure that we always quantify -these first. --} - - -{- ********************************************************************* -* * - Expected kinds -* * -********************************************************************* -} - --- | Describes the kind expected in a certain context. -data ContextKind = TheKind Kind -- ^ a specific kind - | AnyKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - ------------------------ -newExpectedKind :: ContextKind -> TcM Kind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind - ------------------------ -expectedKindInCtxt :: UserTypeCtxt -> ContextKind --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt (TySynCtxt _) = AnyKind -expectedKindInCtxt (GhciCtxt {}) = AnyKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in GHC.Tc.Utils.Env -expectedKindInCtxt DefaultDeclCtxt = AnyKind -expectedKindInCtxt DerivClauseCtxt = AnyKind -expectedKindInCtxt TypeAppCtxt = AnyKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - - -{- ********************************************************************* -* * - Bringing type variables into scope -* * -********************************************************************* -} - --------------------------------------- --- HsForAllTelescope --------------------------------------- - -tcTKTelescope :: TcTyMode - -> HsForAllTelescope GhcRn - -> TcM a - -> TcM ([TcTyVarBinder], a) -tcTKTelescope mode tele thing_inside = case tele of - HsForAllVis { hsf_vis_bndrs = bndrs } - -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside - -- req_tv_bndrs :: [VarBndr TyVar ()], - -- but we want [VarBndr TyVar ArgFlag] - ; return (tyVarReqToBinders req_tv_bndrs, thing) } - - HsForAllInvis { hsf_invis_bndrs = bndrs } - -> do { (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside - -- inv_tv_bndrs :: [VarBndr TyVar Specificity], - -- but we want [VarBndr TyVar ArgFlag] - ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } - where - skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode } - --------------------------------------- --- HsOuterTyVarBndrs --------------------------------------- - -bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed - => SkolemMode - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a - -> TcM (HsOuterTyVarBndrs flag GhcTc, a) -bindOuterTKBndrsX skol_mode outer_bndrs thing_inside - = case outer_bndrs of - HsOuterImplicit{hso_ximplicit = imp_tvs} -> - do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside - ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} - , thing) } - HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' - , hso_bndrs = exp_bndrs } - , thing) } - -getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] --- The returned [TcTyVar] is not necessarily in dependency order --- at least for the HsOuterImplicit case -getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs -getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs - ---------------- -scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder] --- Sort any /implicit/ binders into dependency order --- (zonking first so we can see the dependencies) --- /Explicit/ ones are already in the right order -scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) - = do { imp_tvs <- zonkAndScopedSort imp_tvs - ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] } -scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs}) - = -- No need to dependency-sort (or zonk) explicit quantifiers - return exp_tvs - ---------------- -bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn - -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) -bindOuterSigTKBndrs_Tv - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) - -bindOuterSigTKBndrs_Tv_M :: TcTyMode - -> HsOuterSigTyVarBndrs GhcRn - -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) --- Do not push level; do not make implication constraint; use Tvs --- Two major clients of this "bind-only" path are: --- Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl --- Note [Checking partial type signatures] -bindOuterSigTKBndrs_Tv_M mode - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True - , sm_holes = mode_holes mode }) - -bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn - -> TcM a - -> TcM ([TcTyVar], a) -bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside - = liftFstM getOuterTyVars $ - bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = True }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn - -> TcM a - -> TcM ([TcTyVar], a) -bindOuterFamEqnTKBndrs hs_bndrs thing_inside - = liftFstM getOuterTyVars $ - bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - ---------------- -tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed - => SkolemInfo - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) -tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False }) - -- Do not clone the outer binders - -- See Note [Cloning for type variable binder] under "must not" - -tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed - => SkolemMode -> SkolemInfo - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) --- Push level, capture constraints, make implication -tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside - = case outer_bndrs of - HsOuterImplicit{hso_ximplicit = imp_tvs} -> - do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside - ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} - , thing) } - HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' - , hso_bndrs = exp_bndrs } - , thing) } - --------------------------------------- --- Explicit tyvar binders --------------------------------------- - -tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed - => [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) -tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True }) - -tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed - => SkolemMode - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) --- Push level, capture constraints, --- and emit an implication constraint with a ForAllSkol ic_info, --- so that it is subject to a telescope test. -tcExplicitTKBndrsX skol_mode bndrs thing_inside - = do { (tclvl, wanted, (skol_tvs, res)) - <- pushLevelAndCaptureConstraints $ - bindExplicitTKBndrsX skol_mode bndrs $ - thing_inside - - ; let skol_info = ForAllSkol (fsep (map ppr bndrs)) - -- Notice that we use ForAllSkol here, ignoring the enclosing - -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope - -- test applies only to ForAllSkol - ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted - - ; return (skol_tvs, res) } - ----------------- --- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied --- 'TcTyMode'. -bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag 'Renamed) - => [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) - -bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False }) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) - -- sm_clone: see Note [Cloning for type variable binders] - -bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr () GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) --- These do not clone: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ - bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_kind = ctxt_kind }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside - = liftFstM binderVars $ - bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = True, sm_kind = ctxt_kind }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) - => SkolemMode - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] -bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind - , sm_holes = hole_info }) - hs_tvs thing_inside - = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs) - ; go hs_tvs } - where - tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info } - -- Inherit the HoleInfo from the context - - go [] = do { res <- thing_inside - ; return ([], res) } - go (L _ hs_tv : hs_tvs) - = do { lcl_env <- getLclTypeEnv - ; tv <- tc_hs_bndr lcl_env hs_tv - -- Extend the environment as we go, in case a binder - -- is mentioned in the kind of a later binder - -- e.g. forall k (a::k). blah - -- NB: tv's Name may differ from hs_tv's - -- See Note [Cloning for type variable binders] - ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ - go hs_tvs - ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } - - - tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name)) - | check_parent - , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = return tv - | otherwise - = do { kind <- newExpectedKind ctxt_kind - ; newTyVarBndr skol_mode name kind } - - tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind) - | check_parent - , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind - ; discardResult $ - unifyKind (Just (ppr name)) kind (tyVarKind tv) - -- This unify rejects: - -- class C (m :: * -> *) where - -- type F (m :: *) = ... - ; return tv } - - | otherwise - = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind - ; newTyVarBndr skol_mode name kind } - -newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar -newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind - = do { name <- case clone of - True -> do { uniq <- newUnique - ; return (setNameUnique name uniq) } - False -> return name - ; details <- case tvtv of - True -> newMetaDetails TyVarTv - False -> do { lvl <- getTcLevel - ; return (SkolemTv lvl False) } - ; return (mkTcTyVar name kind details) } - --------------------------------------- --- Implicit tyvar binders --------------------------------------- - -tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) --- The workhorse: --- push level, capture constraints, --- and emit an implication constraint with a ForAllSkol ic_info, --- so that it is subject to a telescope test. -tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside - | null bndrs -- Short-cut the common case with no quantifiers - -- E.g. f :: Int -> Int - -- makes a HsOuterImplicit with empty bndrs, - -- and tcOuterTKBndrsX goes via here - = do { res <- thing_inside; return ([], res) } - | otherwise - = do { (tclvl, wanted, (skol_tvs, res)) - <- pushLevelAndCaptureConstraints $ - bindImplicitTKBndrsX skol_mode bndrs $ - thing_inside - - ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted - - ; return (skol_tvs, res) } - ------------------- -bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv, - bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv - :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = True }) -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True }) -bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True }) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True }) - -bindImplicitTKBndrsX - :: SkolemMode - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed in [Name] -bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind }) - tv_names thing_inside - = do { lcl_env <- getLclTypeEnv - ; tkvs <- mapM (new_tv lcl_env) tv_names - ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs) - ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) - thing_inside - ; return (tkvs, res) } - where - new_tv lcl_env name - | check_parent - , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = return tv - | otherwise - = do { kind <- newExpectedKind ctxt_kind - ; newTyVarBndr skol_mode name kind } - --------------------------------------- --- SkolemMode --------------------------------------- - --- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or --- implicit ('Name') binder in a type. It is just a record of flags --- that describe what sort of 'TcTyVar' to create. -data SkolemMode - = SM { sm_parent :: Bool -- True <=> check the in-scope parent type variable - -- Used only for asssociated types - - , sm_clone :: Bool -- True <=> fresh unique - -- See Note [Cloning for type variable binders] - - , sm_tvtv :: Bool -- True <=> use a TyVarTv, rather than SkolemTv - -- Why? See Note [Inferring kinds for type declarations] - -- in GHC.Tc.TyCl, and (in this module) - -- Note [Checking partial type signatures] - - , sm_kind :: ContextKind -- Use this for the kind of any new binders - - , sm_holes :: HoleInfo -- What to do for wildcards in the kind - } - -smVanilla :: SkolemMode -smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this - , sm_parent = False - , sm_tvtv = False - , sm_kind = AnyKind - , sm_holes = Nothing } - -{- Note [Cloning for type variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes we must clone the Name of a type variable binder (written in -the source program); and sometimes we must not. This is controlled by -the sm_clone field of SkolemMode. - -In some cases it doesn't matter whether or not we clone. Perhaps -it'd be better to use MustClone/MayClone/MustNotClone. - -When we /must not/ clone -* In the binders of a type signature (tcOuterTKBndrs) - f :: forall a{27}. blah - f = rhs - Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType), - we must get the type (forall a{27}. blah) for the Id f, because - we bring that type variable into scope when we typecheck 'rhs'. - -* In the binders of a data family instance (bindOuterFamEqnTKBndrs) - data instance - forall p q. D (p,q) = D1 p | D2 q - We kind-check the LHS in tcDataFamInstHeader, and then separately - (in tcDataFamInstDecl) bring p,q into scope before looking at the - the constructor decls. - -* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone - We take advantage of this in kcInferDeclHeader: - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - If we cloned, we'd need to take a bit more care here; not hard. - -* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone. - There is no need, I think. - - The payoff here is that avoiding gratuitous cloning means that we can - almost always take the fast path in swizzleTcTyConBndrs. - -When we /must/ clone. -* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning - - This for a narrow and tricky reason which, alas, I couldn't find a - simpler way round. #16221 is the poster child: - - data SameKind :: k -> k -> * - data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int - - When kind-checking T, we give (a :: kappa1). Then: - - - In kcConDecl we make a TyVarTv unification variable kappa2 for k2 - (as described in Note [Using TyVarTvs for kind-checking GADTs], - even though this example is an existential) - - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv - - We end up unifying kappa1 := kappa2, because of the (SameKind a b) - - Now we generalise over kappa2. But if kappa2's Name is precisely k2 - (i.e. we did not clone) we'll end up giving T the utterly final kind - T :: forall k2. k2 -> * - Nothing directly wrong with that but when we typecheck the data constructor - we have k2 in scope; but then it's brought into scope /again/ when we find - the forall k2. This is chaotic, and we end up giving it the type - MkT :: forall k2 (a :: k2) k2 (b :: k2). - SameKind @k2 a b -> Int -> T @{k2} a - which is bogus -- because of the shadowing of k2, we can't - apply T to the kind or a! - - And there no reason /not/ to clone the Name when making a unification - variable. So that's what we do. --} - --------------------------------------- --- Binding type/class variables in the --- kind-checking and typechecking phases --------------------------------------- - -bindTyClTyVars :: Name - -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a --- ^ Used for the type variables of a type or class decl --- in the "kind checking" and "type checking" pass, --- but not in the initial-kind run. -bindTyClTyVars tycon_name thing_inside - = do { tycon <- tcLookupTcTyCon tycon_name - ; let scoped_prs = tcTyConScopedTyVars tycon - res_kind = tyConResKind tycon - binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs) - ; tcExtendNameTyVarEnv scoped_prs $ - thing_inside tycon binders res_kind } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs - -- Zonk the kinds, to we can do the dependency analayis - - -- Do a stable topological sort, following - -- Note [Ordering of implicit variables] in GHC.Rename.HsType - ; return (scopedSort spec_tkvs) } - --- | Generalize some of the free variables in the given type. --- All such variables should be *kind* variables; any type variables --- should be explicitly quantified (with a `forall`) before now. --- --- The WantedConstraints are un-solved kind constraints. Generally --- they'll be reported as errors later, but meanwhile we refrain --- from quantifying over any variable free in these unsolved --- constraints. See Note [Failure in local type signatures]. --- --- But in all cases, generalize only those variables whose TcLevel is --- strictly greater than the ambient level. This "strictly greater --- than" means that you likely need to push the level before creating --- whatever type gets passed here. --- --- Any variable whose level is greater than the ambient level but is --- not selected to be generalized will be promoted. (See [Promoting --- unification variables] in "GHC.Tc.Solver" and Note [Recipe for --- checking a signature].) --- --- The resulting KindVar are the variables to quantify over, in the --- correct, well-scoped order. They should generally be Inferred, not --- Specified, but that's really up to the caller of this function. -kindGeneralizeSome :: WantedConstraints - -> TcType -- ^ needn't be zonked - -> TcM [KindVar] -kindGeneralizeSome wanted kind_or_type - = do { -- Use the "Kind" variant here, as any types we see - -- here will already have all type variables quantified; - -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; dvs <- filterConstrainedCandidates wanted dvs - ; quantifyTyVars DefaultNonStandardTyVars dvs } - -filterConstrainedCandidates - :: WantedConstraints -- Don't quantify over variables free in these - -- Not necessarily fully zonked - -> CandidatesQTvs -- Candidates for quantification - -> TcM CandidatesQTvs --- filterConstrainedCandidates removes any candidates that are free in --- 'wanted'; instead, it promotes them. This bit is very much like --- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much --- simpler in kinds, it is much easier here. (In particular, we never --- quantify over a constraint in a type.) -filterConstrainedCandidates wanted dvs - | isEmptyWC wanted -- Fast path for a common case - = return dvs - | otherwise - = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) - ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) - ; _ <- promoteTyVarSet to_promote - ; return dvs' } - --- |- Specialised version of 'kindGeneralizeSome', but with empty --- WantedConstraints, so no filtering is needed --- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC -kindGeneralizeAll :: TcType -> TcM [KindVar] -kindGeneralizeAll kind_or_type - = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; quantifyTyVars DefaultNonStandardTyVars dvs } - --- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized, but perhaps some may need to be promoted. --- Use this variant when it is unknowable whether metavariables might --- later be constrained. --- --- To see why this promotion is needed, see --- Note [Recipe for checking a signature], and especially --- Note [Promotion in signatures]. -kindGeneralizeNone :: TcType -- needn't be zonked - -> TcM () -kindGeneralizeNone kind_or_type - = do { traceTc "kindGeneralizeNone" (ppr kind_or_type) - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; _ <- promoteTyVarSet (candidateKindVars dvs) - ; return () } - -{- Note [Levels and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = e -with no type signature. We are currently at level i. -We must - * Push the level to level (i+1) - * Allocate a fresh alpha[i+1] for the result type - * Check that e :: alpha[i+1], gathering constraint WC - * Solve WC as far as possible - * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] - * Find the free variables with level > i, in this case gamma[i] - * Skolemise those free variables and quantify over them, giving - f :: forall g. beta[i-1] -> g - * Emit the residiual constraint wrapped in an implication for g, - thus forall g. WC - -All of this happens for types too. Consider - f :: Int -> (forall a. Proxy a -> Int) - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do kind generalisation only at the outer level of a type signature. -For example, consider - T :: forall k. k -> * - f :: (forall a. T a -> Int) -> Int -When kind-checking f's type signature we generalise the kind at -the outermost level, thus: - f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! -and *not* at the inner forall: - f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! -Reason: same as for HM inference on value level declarations, -we want to infer the most general type. The f2 type signature -would be *less applicable* than f1, because it requires a more -polymorphic argument. - -NB: There are no explicit kind variables written in f's signature. -When there are, the renamer adds these kind variables to the list of -variables bound by the forall, so you can indeed have a type that's -higher-rank in its kind. But only by explicit request. - -Note [Kinds of quantified type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsGen quantifies over a specified list of type variables, -*and* over the kind variables mentioned in the kinds of those tyvars. - -Note that we must zonk those kinds (obviously) but less obviously, we -must return type variables whose kinds are zonked too. Example - (a :: k7) where k7 := k9 -> k9 -We must return - [k9, a:k9->k9] -and NOT - [k9, a:k7] -Reason: we're going to turn this into a for-all type, - forall k9. forall (a:k7). blah -which the type checker will then instantiate, and instantiate does not -look through unification variables! - -Hence using zonked_kinds when forming tvs'. - --} - ------------------------------------ -etaExpandAlgTyCon :: [TyConBinder] - -> Kind -- must be zonked - -> TcM ([TyConBinder], Kind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T a :: * -> * -> * where ... --- This function makes up suitable (kinded) TyConBinders for the --- argument kinds. E.g. in this case it might return --- ([b::*, c::*], *) --- Never emits constraints. --- It's a little trickier than you might think: see --- Note [TyConBinders for the result kind signature of a data type] --- See Note [Datatype return kinds] in GHC.Tc.TyCl -etaExpandAlgTyCon tc_bndrs kind - = do { loc <- getSrcSpanM - ; uniqs <- newUniqueSupply - ; rdr_env <- getLocalRdrEnv - ; let new_occs = [ occ - | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) - -- Note [Avoid name clashes for associated data types] - , not (occ `elem` lhs_occs) ] - new_uniqs = uniqsFromSupply uniqs - subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs)) - ; return (go loc new_occs new_uniqs subst [] kind) } - where - lhs_tvs = map binderVar tc_bndrs - lhs_occs = map getOccName lhs_tvs - - go loc occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon af arg, kind') - -> go loc occs' uniqs' subst' (tcb : acc) kind' - where - arg' = substTy subst (scaledThing arg) - tv = mkTyVar (mkInternalName uniq occ loc) arg' - subst' = extendTCvInScope subst tv - tcb = Bndr tv (AnonTCB af) - (uniq:uniqs') = uniqs - (occ:occs') = occs - - Just (Named (Bndr tv vis), kind') - -> go loc occs uniqs subst' (tcb : acc) kind' - where - (subst', tv') = substTyVarBndr subst tv - tcb = Bndr tv' (NamedTCB vis) - --- | A description of whether something is a --- --- * @data@ or @newtype@ ('DataDeclSort') --- --- * @data instance@ or @newtype instance@ ('DataInstanceSort') --- --- * @data family@ ('DataFamilySort') --- --- At present, this data type is only consumed by 'checkDataKindSig'. -data DataSort - = DataDeclSort NewOrData - | DataInstanceSort NewOrData - | DataFamilySort - --- | Local helper type used in 'checkDataKindSig'. --- --- Superficially similar to 'ContextKind', but it lacks 'AnyKind' --- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ --- provides 'LiftedKind', which is much simpler to match on and --- handle in 'isAllowedDataResKind'. -data AllowedDataResKind - = AnyTYPEKind - | AnyBoxedKind - | LiftedKind - -isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool -isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind -isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind -isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind - --- | Checks that the return kind in a data declaration's kind signature is --- permissible. There are three cases: --- --- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ --- declaration, check that the return kind is @Type@. --- --- If the declaration is a @newtype@ or @newtype instance@ and the --- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so --- that a return kind of the form @TYPE r@ (for some @r@) is permitted. --- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". --- --- If dealing with a @data family@ declaration, check that the return kind is --- either of the form: --- --- 1. @TYPE r@ (for some @r@), or --- --- 2. @k@ (where @k@ is a bare kind variable; see #12369) --- --- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" -checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off - -> TcM () -checkDataKindSig data_sort kind - = do { dflags <- getDynFlags - ; traceTc "checkDataKindSig" (ppr kind) - ; checkTc (tYPE_ok dflags || is_kind_var) - (err_msg dflags) } - where - res_kind = snd (tcSplitPiTys kind) - -- Look for the result kind after - -- peeling off any foralls and arrows - - pp_dec :: SDoc - pp_dec = text $ - case data_sort of - DataDeclSort DataType -> "Data type" - DataDeclSort NewType -> "Newtype" - DataInstanceSort DataType -> "Data instance" - DataInstanceSort NewType -> "Newtype instance" - DataFamilySort -> "Data family" - - is_newtype :: Bool - is_newtype = - case data_sort of - DataDeclSort new_or_data -> new_or_data == NewType - DataInstanceSort new_or_data -> new_or_data == NewType - DataFamilySort -> False - - is_datatype :: Bool - is_datatype = - case data_sort of - DataDeclSort DataType -> True - DataInstanceSort DataType -> True - _ -> False - - is_data_family :: Bool - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - - allowed_kind :: DynFlags -> AllowedDataResKind - allowed_kind dflags - | is_newtype && xopt LangExt.UnliftedNewtypes dflags - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. - = AnyTYPEKind - | is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - = AnyTYPEKind - | is_datatype && xopt LangExt.UnliftedDatatypes dflags - -- With UnliftedDatatypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE (BoxedRep l)`, so that we don't - -- accept result kinds like `TYPE IntRep`. - -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. - = AnyBoxedKind - | otherwise - = LiftedKind - - tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind - - -- In the particular case of a data family, permit a return kind of the - -- form `:: k` (where `k` is a bare kind variable). - is_kind_var :: Bool - is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind) - | otherwise = False - - pp_allowed_kind dflags = - case allowed_kind dflags of - AnyTYPEKind -> ppr tYPETyCon - AnyBoxedKind -> ppr boxedRepDataConTyCon - LiftedKind -> ppr liftedTypeKind - - err_msg :: DynFlags -> TcRnMessage - err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $ - sep [ sep [ pp_dec <+> - text "has non-" <> - pp_allowed_kind dflags - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) ] - , ext_hint dflags ] - - ext_hint dflags - | tcIsRuntimeTypeKind kind - , is_newtype - , not (xopt LangExt.UnliftedNewtypes dflags) - = text "Perhaps you intended to use UnliftedNewtypes" - | tcIsBoxedTypeKind kind - , is_datatype - , not (xopt LangExt.UnliftedDatatypes dflags) - = text "Perhaps you intended to use UnliftedDatatypes" - | otherwise - = empty - --- | Checks that the result kind of a class is exactly `Constraint`, rejecting --- type synonyms and type families that reduce to `Constraint`. See #16826. -checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg - where - err_msg :: TcRnMessage - err_msg = TcRnUnknownMessage $ mkPlainError noHints $ - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" - -tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] --- Result is in 1-1 correspondence with orig_args -tcbVisibilities tc orig_args - = go (tyConKind tc) init_subst orig_args - where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) - go _ _ [] - = [] - - go fun_kind subst all_args@(arg : args) - | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind - = case tcb of - Anon af _ -> AnonTCB af : go inner_kind subst args - Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args - where - subst' = extendTCvSubst subst tv arg - - | not (isEmptyTCvSubst subst) - = go (substTy subst fun_kind) init_subst all_args - - | otherwise - = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) - - -{- Note [TyConBinders for the result kind signature of a data type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - data T (a::*) :: * -> forall k. k -> * -we want to generate the extra TyConBinders for T, so we finally get - (a::*) (b::*) (k::*) (c::k) -The function etaExpandAlgTyCon generates these extra TyConBinders from -the result kind signature. - -We need to take care to give the TyConBinders - (a) OccNames that are fresh (because the TyConBinders of a TyCon - must have distinct OccNames - - (b) Uniques that are fresh (obviously) - -For (a) we need to avoid clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. -And also see Note [Avoid name clashes for associated data types]. - -For (b) suppose we have - data T :: forall k. k -> forall k. k -> * -where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515. - -It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But it has to be -done. - -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to Iface syntax, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcType -- Extra-constraints wildcard - , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with - -- the implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part --- See Note [Checking partial type signatures] -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty - , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty - , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty - = addSigCtxt ctxt sig_ty $ - do { mode <- mkHoleMode TypeLevel HM_Sig - ; (outer_bndrs, (wcs, wcx, theta, tau)) - <- solveEqualities "tcHsPartialSigType" $ - -- See Note [Failure in local type signatures] - bindNamedWildCardBinders sig_wcs $ \ wcs -> - bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $ - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext mode hs_ctxt - - ; ek <- newOpenTypeKind - ; tau <- addTypeCtxt hs_tau $ - tc_lhs_type mode hs_tau ek - - ; return (wcs, wcx, theta, tau) } - - ; traceTc "tcHsPartialSigType 2" empty - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs - ; traceTc "tcHsPartialSigType 3" empty - - -- No kind-generalization here: - ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy theta $ - tau) - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; mapM_ emitNamedTypeHole wcs - - -- Zonk, so that any nested foralls can "see" their occurrences - -- See Note [Checking partial type signatures], and in particular - -- Note [Levels for wildcards] - ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs - ; theta <- mapM zonkTcType theta - ; tau <- zonkTcType tau - - -- We return a proper (Name,InvisTVBinder) environment, to be sure that - -- we bring the right name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let outer_bndr_names :: [Name] - outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs - tv_prs :: [(Name,InvisTVBinder)] - tv_prs = outer_bndr_names `zip` outer_tv_bndrs - - -- NB: checkValidType on the final inferred type will be - -- done later by checkInferredPolyId. We can't do it - -- here because we don't have a complete type to check - - ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } - -tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) -tcPartialContext _ Nothing = return ([], Nothing) -tcPartialContext mode (Just (L _ hs_theta)) - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpanA wc_loc $ - tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind - ; theta <- mapM (tc_lhs_pred mode) hs_theta1 - ; return (theta, Just wc_tv_ty) } - | otherwise - = do { theta <- mapM (tc_lhs_pred mode) hs_theta - ; return (theta, Nothing) } - -{- Note [Checking partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note is about tcHsPartialSigType. See also -Note [Recipe for checking a signature] - -When we have a partial signature like - f :: forall a. a -> _ -we do the following - -* tcHsPartialSigType does not make quantified type (forall a. blah) - and then instantiate it -- it makes no sense to instantiate a type - with wildcards in it. Rather, tcHsPartialSigType just returns the - 'a' and the 'blah' separately. - - Nor, for the same reason, do we push a level in tcHsPartialSigType. - -* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ - a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider - f :: forall a. a -> _ - g :: forall b. _ -> b - f = g - g = f - They are typechecked as a recursive group, with monomorphic types, - so 'a' and 'b' will get unified together. Very like kind inference - for mutually recursive data types (sans CUSKs or SAKS); see - Note [Cloning for type variable binders] - -* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike - the companion CompleteSig) contains the original, as-yet-unchecked - source-code LHsSigWcType - -* Then, for f and g /separately/, we call tcInstSig, which in turn - call tchsPartialSig (defined near this Note). It kind-checks the - LHsSigWcType, creating fresh unification variables for each "_" - wildcard. It's important that the wildcards for f and g are distinct - because they might get instantiated completely differently. E.g. - f,g :: forall a. a -> _ - f x = a - g x = True - It's really as if we'd written two distinct signatures. - -* Nested foralls. See Note [Levels for wildcards] - -* Just as for ordinary signatures, we must solve local equalities and - zonk the type after kind-checking it, to ensure that all the nested - forall binders can "see" their occurrenceds - - Just as for ordinary signatures, this zonk also gets any Refl casts - out of the way of instantiation. Example: #18008 had - foo :: (forall a. (Show a => blah) |> Refl) -> _ - and that Refl cast messed things up. See #18062. - -Note [Levels for wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b. (forall a. a -> _) -> b -We do /not/ allow the "_" to be instantiated to 'a'; although we do -(as before) allow it to be instantiated to the (top level) 'b'. -Why not? Suppose - f x = (x True, x 'c') - -During typecking the RHS we must instantiate that (forall a. a -> _), -so we must know /precisely/ where all the a's are; they must not be -hidden under (possibly-not-yet-filled-in) unification variables! - -We achieve this as follows: - -- For /named/ wildcards such sas - g :: forall b. (forall la. a -> _x) -> b - there is no problem: we create them at the outer level (ie the - ambient level of the signature itself), and push the level when we - go inside a forall. So now the unification variable for the "_x" - can't unify with skolem 'a'. - -- For /anonymous/ wildcards, such as 'f' above, we carry the ambient - level of the signature to the hole in the TcLevel part of the - mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that - level (and /not/ the level ambient at the occurrence of "_") to - create the unification variable for the wildcard. That is the sole - purpose of the TcLevel in the mode_holes field: to transport the - ambient level of the signature down to the anonymous wildcard - occurrences. - -Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer leaves '_' untouched. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBinders. - -* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* GHC.Tc.Errors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 64 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how -can we make a 70-tuple? This was the root cause of #14217. - -It's incredibly tiresome, because we only need this type to fill -in the hole, to communicate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain constraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an associated class). - -* Because it is ill-kinded (unifying something of kind Constraint with - something of kind Type), it should trip an assert in writeMetaTyVarRef. - However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling - over in this scenario (and another scenario, as detailed in - Note [coreView vs tcView] in GHC.Core.Type). - -Result works fine, but it may eventually bite us. - -See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for -information about how these are printed. - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. - -> HsPatSigType GhcRn -- The type signature - -> ContextKind -- What kind is expected - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- See Note [Pattern signature binders and scoping] in GHC.Hs.Type --- --- This may emit constraints --- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt hole_mode - (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } - , hsps_body = hs_ty }) - ctxt_kind - = addSigCtxt ctxt hs_ty $ - do { sig_tkv_prs <- mapM new_implicit_tv sig_ns - ; mode <- mkHoleMode TypeLevel hole_mode - ; (wcs, sig_ty) - <- addTypeCtxt hs_ty $ - solveEqualities "tcHsPatSigType" $ - -- See Note [Failure in local type signatures] - -- and c.f #16033 - bindNamedWildCardBinders sig_wcs $ \ wcs -> - tcExtendNameTyVarEnv sig_tkv_prs $ - do { ek <- newExpectedKind ctxt_kind - ; sig_ty <- tc_lhs_type mode hs_ty ek - ; return (wcs, sig_ty) } - - ; mapM_ emitNamedTypeHole wcs - - -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty - -- contains a forall). Promote these. - -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... - -- When we instantiate x, we have to compare the kind of the argument - -- to a's kind, which will be a metavariable. - -- kindGeneralizeNone does this: - ; kindGeneralizeNone sig_ty - ; sig_ty <- zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) - ; return (wcs, sig_tkv_prs, sig_ty) } - where - new_implicit_tv name - = do { kind <- newMetaKindVar - ; tv <- case ctxt of - RuleSigCtxt {} -> newSkolemTyVar name kind - _ -> newPatSigTyVar name kind - -- See Note [Typechecking pattern signature binders] - -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) - ; return (name, tv) } - -{- Note [Typechecking pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Type variables in the type environment] in GHC.Tc.Utils. -Consider - - data T where - MkT :: forall a. a -> (a -> Int) -> T - - f :: T -> ... - f (MkT x (f :: b -> c)) = - -Here - * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that it retains its identity, and - GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b -> c) makes fresh meta-tyvars - beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the - environment - - * Then unification makes beta := a_sk, gamma := Int - That's why we must make beta and gamma a MetaTv, - not a SkolemTv, so that it can unify to a_sk (or Int, respectively). - - * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, - so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, - -Another example (#13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check -the pattern signature - Sing (l :: [y]) -That unifies y_sig := a_sk. We return from tcHsPatSigType with -the pair ("y" :-> y_sig). - -For RULE binders, though, things are a bit different (yuk). - RULE "foo" forall (x::a) (y::[a]). f x y = ... -Here this really is the binding site of the type variable so we'd like -to use a skolem, so that we get a complaint if we unify two of them -together. Hence the new_implicit_tv function in tcHsPatSigType. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds rn_tys act_kinds - = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) - = checkExpectedKind (unLoc rn_ty) ty act_kind kind - ; tys' <- zipWithM check rn_tys act_kinds - ; return (tys', kind) } - -{- -************************************************************************ -* * - Sort checking kinds -* * -************************************************************************ - -tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. -It does sort checking and desugaring at the same time, in one single pass. --} - -tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tcLHsKindSig ctxt hs_kind - = tc_lhs_kind_sig kindLevelMode ctxt hs_kind - -tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tc_lhs_kind_sig mode ctxt hs_kind --- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType --- Result is zonked - = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $ - solveEqualities "tcLHsKindSig" $ - tc_lhs_type mode hs_kind liftedTypeKind - ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) - -- No generalization: - ; kindGeneralizeNone kind - ; kind <- zonkTcType kind - -- This zonk is very important in the case of higher rank kinds - -- E.g. #13879 f :: forall (p :: forall z (y::z). ). - -- - -- When instantiating p's kind at occurrences of p in - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - - ; checkValidType ctxt kind - ; traceTc "tcLHsKindSig2" (ppr kind) - ; return kind } - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - ConstrainedDataConPE pred - -> text "it has an unpromotable context" - <+> quotes (ppr pred) - FamDataConPE -> text "it comes from a data family instance" - NoDataKindsTC -> text "perhaps you intended to use DataKinds" +{-# LANGUAGE RecursiveDo #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking user-specified @MonoTypes@ +module GHC.Tc.Gen.HsType ( + -- Type signatures + kcClassSigType, tcClassSigType, + tcHsSigType, tcHsSigWcType, + tcHsPartialSigType, + tcStandaloneKindSig, + funsSigCtxt, addSigCtxt, pprSigCtxt, + + tcHsClsInstType, + tcHsDeriv, tcDerivStrategy, + tcHsTypeApp, + UserTypeCtxt(..), + bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, + bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, + bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + + bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs, + tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs, + bindOuterSigTKBndrs_Tv, + tcExplicitTKBndrs, + bindNamedWildCardBinders, + + -- Type checking type and class decls, and instances thereof + bindTyClTyVars, bindTyClTyVarsAndZonk, + tcFamTyPats, + etaExpandAlgTyCon, tcbVisibilities, + + -- tyvars + zonkAndScopedSort, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + InitialKindStrategy(..), + SAKS_or_CUSK(..), + ContextKind(..), + kcDeclHeader, checkForDuplicateScopedTyVars, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, + tcCheckLHsType, + tcHsContext, tcLHsPredType, + + kindGeneralizeAll, + + -- Sort-checking kinds + tcLHsKindSig, checkDataKindSig, DataSort(..), + checkClassKindSig, + + -- Multiplicity + tcMult, + + -- Pattern type signatures + tcHsPatSigType, + HoleMode(..), + + -- Error messages + funAppCtxt, addTyConFlavCtxt + ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Rename.Utils +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Core.Predicate +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity +import GHC.Tc.Utils.Unify +import GHC.IfaceToCore +import GHC.Tc.Solver +import GHC.Tc.Utils.Zonk +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, + tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs ) +import GHC.Core.Type +import GHC.Builtin.Types.Prim +import GHC.Types.Error +import GHC.Types.Name.Env +import GHC.Types.Name.Reader( lookupLocalRdrOcc ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Types.Name +-- import GHC.Types.Name.Set +import GHC.Types.Var.Env +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Builtin.Names hiding ( wildCardName ) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Data.Bag( unitBag ) + +import Data.Function ( on ) +import Data.List.NonEmpty as NE( NonEmpty(..), nubBy ) +import Data.List ( find, mapAccumL ) +import Control.Monad +import Data.Tuple( swap ) + +{- + ---------------------------- + General notes + ---------------------------- + +Unlike with expressions, type-checking types both does some checking and +desugars at the same time. This is necessary because we often want to perform +equality checks on the types right away, and it would be incredibly painful +to do this on un-desugared types. Luckily, desugared types are close enough +to HsTypes to make the error messages sane. + +During type-checking, we perform as little validity checking as possible. +Generally, after type-checking, you will want to do validity checking, say +with GHC.Tc.Validity.checkValidType. + +Validity checking +~~~~~~~~~~~~~~~~~ +Some of the validity check could in principle be done by the kind checker, +but not all: + +- During desugaring, we normalise by expanding type synonyms. Only + after this step can we check things like type-synonym saturation + e.g. type T k = k Int + type S a = a + Then (T S) is ok, because T is saturated; (T S) expands to (S Int); + and then S is saturated. This is a GHC extension. + +- Similarly, also a GHC extension, we look through synonyms before complaining + about the form of a class or instance declaration + +- Ambiguity checks involve functional dependencies + +Also, in a mutually recursive group of types, we can't look at the TyCon until we've +finished building the loop. So to keep things simple, we postpone most validity +checking until step (3). + +%************************************************************************ +%* * + Check types AND do validity checking +* * +************************************************************************ + +Note [Keeping implicitly quantified variables in order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user implicitly quantifies over variables (say, in a type +signature), we need to come up with some ordering on these variables. +This is done by bumping the TcLevel, bringing the tyvars into scope, +and then type-checking the thing_inside. The constraints are all +wrapped in an implication, which is then solved. Finally, we can +zonk all the binders and then order them with scopedSort. + +It's critical to solve before zonking and ordering in order to uncover +any unifications. You might worry that this eager solving could cause +trouble elsewhere. I don't think it will. Because it will solve only +in an increased TcLevel, it can't unify anything that was mentioned +elsewhere. Additionally, we require that the order of implicitly +quantified variables is manifest by the scope of these variables, so +we're not going to learn more information later that will help order +these variables. + +Note [Recipe for checking a signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind-checking a user-written signature requires several steps: + + 0. Bump the TcLevel + 1. Bind any lexically-scoped type variables. + 2. Generate constraints. + 3. Solve constraints. + 4. Sort any implicitly-bound variables into dependency order + 5. Promote tyvars and/or kind-generalize. + 6. Zonk. + 7. Check validity. + +Very similar steps also apply when kind-checking a type or class +declaration. + +The general pattern looks something like this. (But NB every +specific instance varies in one way or another!) + + do { (tclvl, wanted, (spec_tkvs, ty)) + <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ + bindImplicitTKBndrs_Skol sig_vars $ + + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + + ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted + + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralizeAll ty1 + + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) + + ; checkValidType final_ty + +This pattern is repeated many times in GHC.Tc.Gen.HsType, +GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail: + +* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel, + calls the thing inside to generate constraints, solves those + constraints as much as possible, returning the residual unsolved + constraints in 'wanted'. + +* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type + variables E.g. when kind-checking f :: forall a. F a -> a we must + bring 'a' into scope before kind-checking (F a -> a) + +* zonkAndScopedSort (Step 4) puts those user-specified variables in + the dependency order. (For "implicit" variables the order is no + user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are + implicitly brought into scope. + +* reportUnsolvedEqualities (Step 3 continued) reports any unsolved + equalities, carefully wrapping them in an implication that binds the + skolems. We can't do that in pushLevelAndSolveEqualitiesX because + that function doesn't have access to the skolems. + +* kindGeneralize (Step 5). See Note [Kind generalisation] + +* The final zonkTcTypeToType must happen after promoting/generalizing, + because promoting and generalizing fill in metavariables. + + +Doing Step 3 (constraint solving) eagerly (rather than building an +implication constraint and solving later) is necessary for several +reasons: + +* Exactly as for Solver.simplifyInfer: when generalising, we solve all + the constraints we can so that we don't have to quantify over them + or, since we don't quantify over constraints in kinds, float them + and inhibit generalisation. + +* Most signatures also bring implicitly quantified variables into + scope, and solving is necessary to get these in the right order + (Step 4) see Note [Keeping implicitly quantified variables in + order]). + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Step 5 of Note [Recipe for checking a signature], namely +kind-generalisation, is done by + kindGeneraliseAll + kindGeneraliseSome + kindGeneraliseNone + +Here, we have to deal with the fact that metatyvars generated in the +type will have a bumped TcLevel, because explicit foralls raise the +TcLevel. To avoid these variables from ever being visible in the +surrounding context, we must obey the following dictum: + + Every metavariable in a type must either be + (A) generalized, or + (B) promoted, or See Note [Promotion in signatures] + (C) a cause to error See Note [Naughty quantification candidates] + in GHC.Tc.Utils.TcMType + +There are three steps (look at kindGeneraliseSome): + +1. candidateQTyVarsOfType finds the free variables of the type or kind, + to generalise + +2. filterConstrainedCandidates filters out candidates that appear + in the unsolved 'wanteds', and promotes the ones that get filtered out + thereby. + +3. quantifyTyVars quantifies the remaining type variables + +The kindGeneralize functions do not require pre-zonking; they zonk as they +go. + +kindGeneraliseAll specialises for the case where step (2) is vacuous. +kindGeneraliseNone specialises for the case where we do no quantification, +but we must still promote. + +If you are actually doing kind-generalization, you need to bump the +level before generating constraints, as we will only generalize +variables with a TcLevel higher than the ambient one. +Hence the "pushLevel" in pushLevelAndSolveEqualities. + +Note [Promotion in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an unsolved metavariable in a signature is not generalized +(because we're not generalizing the construct -- e.g., pattern +sig -- or because the metavars are constrained -- see kindGeneralizeSome) +we need to promote to maintain (WantedInv) of Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing +and the reinstantiating with a fresh metavariable at the current level. +So in some sense, we generalize *all* variables, but then re-instantiate +some of them. + +Here is an example of why we must promote: + foo (x :: forall a. a -> Proxy b) = ... + +In the pattern signature, `b` is unbound, and will thus be brought into +scope. We do not know its kind: it will be assigned kappa[2]. Note that +kappa is at TcLevel 2, because it is invented under a forall. (A priori, +the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel +than the surrounding context.) This kappa cannot be solved for while checking +the pattern signature (which is not kind-generalized). When we are checking +the *body* of foo, though, we need to unify the type of x with the argument +type of bar. At this point, the ambient TcLevel is 1, and spotting a +matavariable with level 2 would violate the (WantedInv) invariant of +Note [TcLevel invariants]. So, instead of kind-generalizing, +we promote the metavariable to level 1. This is all done in kindGeneralizeNone. + +-} + +funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a +addSigCtxt ctxt hs_ty thing_inside + = setSrcSpan (getLocA hs_ty) $ + addErrCtxt (pprSigCtxt ctxt hs_ty) $ + thing_inside + +pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The is either empty or "the ambiguity check for" +pprSigCtxt ctxt hs_ty + | Just n <- isSigMaybe ctxt + = hang (text "In the type signature:") + 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) + + | otherwise + = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) + 2 (ppr hs_ty) + +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type +-- This one is used when we have a LHsSigWcType, but in +-- a place where wildcards aren't allowed. The renamer has +-- already checked this, so we can simply ignore it. +tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) + +kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () +-- This is a special form of tcClassSigType that is used during the +-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. +-- Importantly, this does *not* kind-generalize. Consider +-- class SC f where +-- meth :: forall a (x :: f a). Proxy x -> () +-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're +-- still working out the kind of f, and thus f a will have a coercion in it. +-- Coercions block unification (Note [Equalities with incompatible kinds] in +-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll +-- end up promoting kappa to the top level (because kind-generalization is +-- normally done right before adding a binding to the context), and then we +-- can't set kappa := f a, because a is local. +kcClassSigType names + sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty })) + = addSigCtxt (funsSigCtxt names) sig_ty $ + do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $ + tcLHsType hs_ty liftedTypeKind + ; return () } + +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type +-- Does not do validity checking +tcClassSigType names sig_ty + = addSigCtxt sig_ctxt sig_ty $ + do { skol_info <- mkSkolemInfo skol_info_anon + ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + ; emitImplication implic + ; return ty } + -- Do not zonk-to-Type, nor perform a validity check + -- We are in a knot with the class and associated types + -- Zonking and validity checking is done by tcClassDecl + -- + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. + where + sig_ctxt = funsSigCtxt names + skol_info_anon = SigTypeSkol sig_ctxt + +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- Does validity checking +-- See Note [Recipe for checking a signature] +tcHsSigType ctxt sig_ty + = addSigCtxt ctxt sig_ty $ + do { traceTc "tcHsSigType {" (ppr sig_ty) + ; skol_info <- mkSkolemInfo skol_info + -- Generalise here: see Note [Kind generalisation] + ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) + + -- Float out constraints, failing fast if not possible + -- See Note [Failure in local type signatures] in GHC.Tc.Solver + ; traceTc "tcHsSigType 2" (ppr implic) + ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) + + ; ty <- zonkTcType ty + ; checkValidType ctxt ty + ; traceTc "end tcHsSigType }" (ppr ty) + ; return ty } + where + skol_info = SigTypeSkol ctxt + +tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn + -> ContextKind -> TcM (Implication, TcType) +-- Kind-checks/desugars an 'LHsSigType', +-- solve equalities, +-- and then kind-generalizes. +-- This will never emit constraints, as it uses solveEqualities internally. +-- No validity checking or zonking +-- Returns also an implication for the unsolved constraints +tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs + , sig_body = hs_ty })) ctxt_kind + = setSrcSpanA loc $ + do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty))) + <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ + -- See Note [Failure in local type signatures] + do { exp_kind <- newExpectedKind ctxt_kind + -- See Note [Escaping kind in type signatures] + ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $ + tcLHsType hs_ty exp_kind + ; return (exp_kind, stuff) } + + -- Default any unconstrained variables free in the kind + -- See Note [Escaping kind in type signatures] + ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind + ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind) + + ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) + ; outer_bndrs <- scopedSortOuter outer_bndrs + + ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs + ty1 = mkInvisForAllTys outer_tv_bndrs ty + ; kvs <- kindGeneralizeSome skol_info wanted ty1 + + -- Build an implication for any as-yet-unsolved kind equalities + -- See Note [Skolem escape in type signatures] + ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted + + ; return (implic, mkInfForAllTys kvs ty1) } + where + mk_doc exp_kind tidy_env + = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind + ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind) + 2 (text "of type signature:" <+> ppr full_hs_ty)) } + + + +{- Note [Escaping kind in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider kind-checking the signature for `foo` (#19495): + type family T (r :: RuntimeRep) :: TYPE r + + foo :: forall (r :: RuntimeRep). T r + foo = ... + +We kind-check the type with expected kind `TYPE delta` (see newExpectedKind), +where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep` +because we allow signatures like `foo :: Int#`.) + +Suppose we are at level L currently. We do this + * pushLevelAndSolveEqualitiesX: moves to level L+1 + * newExpectedKind: allocates delta{L+1} + * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2} + * kind-check the body (T r) :: TYPE delta{L+1} + +Then +* We can't unify delta{L+1} with r{L+2}. + And rightly so: skolem would escape. + +* If delta{L+1} is unified with some-kind{L}, that is fine. + This can happen + \(x::a) -> let y :: a; y = x in ...(x :: Int#)... + Here (x :: a :: TYPE gamma) is in the environment when we check + the signature y::a. We unify delta := gamma, and all is well. + +* If delta{L+1} is unconstrained, we /must not/ quantify over it! + E.g. Consider f :: Any where Any :: forall k. k + We kind-check this with expected kind TYPE kappa. We get + Any @(TYPE kappa) :: TYPE kappa + We don't want to generalise to forall k. Any @k + because that is ill-kinded: the kind of the body of the forall, + (Any @k :: k) mentions the bound variable k. + + Instead we want to default it to LiftedRep. + + An alternative would be to promote it, similar to the monomorphism + restriction, but the MR is pretty confusing. Defaulting seems better + +How does that defaulting happen? Well, since we /currently/ default +RuntimeRep variables during generalisation, it'll happen in +kindGeneralize. But in principle we might allow generalisation over +RuntimeRep variables in future. Moreover, what if we had + kappa{L+1} := F alpha{L+1} +where F :: Type -> RuntimeRep. Now it's alpha that is free in the kind +and it /won't/ be defaulted. + +So we use doNotQuantifyTyVars to either default the free vars of +exp_kind (if possible), or error (if not). + +Note [Skolem escape in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcHsSigType is tricky. Consider (T11142) + foo :: forall b. (forall k (a :: k). SameKind a b) -> () +This is ill-kinded because of a nested skolem-escape. + +That will show up as an un-solvable constraint in the implication +returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem +escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable +(the unification variable for b's kind is untouchable). + +Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType) +we'll try to float out the constraint, be unable to do so, and fail. +See GHC.Tc.Solver Note [Failure in local type signatures] for more +detail on this. + +The separation between tcHsSigType and tc_lhs_sig_type is because +tcClassSigType wants to use the latter, but *not* fail fast, because +there are skolems from the class decl which are in scope; but it's fine +not to because tcClassDecl1 has a solveEqualities wrapped around all +the tcClassSigType calls. + +That's why tcHsSigType does simplifyAndEmitFlatConstraints (which +fails fast) but tcClassSigType just does emitImplication (which does +not). Ugh. + +c.f. see also Note [Skolem escape and forall-types]. The difference +is that we don't need to simplify at a forall type, only at the +top level of a signature. +-} + +-- Does validity checking and zonking. +tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) +tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig)) + = addSigCtxt ctxt ksig $ + do { kind <- tc_top_lhs_type KindLevel ctxt ksig + ; checkValidType ctxt kind + ; return (name, kind) } + where + ctxt = StandaloneKindSigCtxt name + +tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +tcTopLHsType ctxt lsig_ty + = checkNoErrs $ -- Fail eagerly to avoid follow-on errors. We are at + -- top level so these constraints will never be solved later. + tc_top_lhs_type TypeLevel ctxt lsig_ty + +tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where +-- we want to fully solve /all/ equalities, and report errors +-- Does zonking, but not validity checking because it's used +-- for things (like deriving and instances) that aren't +-- ordinary types +-- Used for both types and kinds +tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs + , sig_body = body })) + = setSrcSpanA loc $ + do { traceTc "tc_top_lhs_type {" (ppr sig_ty) + ; skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (outer_bndrs, ty)) + <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ + tcOuterTKBndrs skol_info hs_outer_bndrs $ + do { kind <- newExpectedKind (expectedKindInCtxt ctxt) + ; tc_lhs_type (mkMode tyki) body kind } + + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs + ty1 = mkInvisForAllTys outer_tv_bndrs ty + + ; kvs <- kindGeneralizeAll skol_info ty1 -- "All" because it's a top-level type + ; reportUnsolvedEqualities skol_info kvs tclvl wanted + + ; ze <- mkEmptyZonkEnv NoFlexi + ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1) + ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) + ; return final_ty } + where + skol_info_anon = SigTypeSkol ctxt + +----------------- +tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind]) +-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause +-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments +-- E.g. class C (a::*) (b::k->k) +-- data T a b = ... deriving( C Int ) +-- returns ([k], C, [k, Int], [k->k]) +-- Return values are fully zonked +tcHsDeriv hs_ty + = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty + ; let (tvs, pred) = splitForAllTyCoVars ty + (kind_args, _) = splitFunTys (tcTypeKind pred) + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) + Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + +-- | Typecheck a deriving strategy. For most deriving strategies, this is a +-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. +tcDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -- ^ The deriving strategy + -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar]) + -- ^ The typechecked deriving strategy and the tyvars that it binds + -- (if using 'ViaStrategy'). +tcDerivStrategy mb_lds + = case mb_lds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpanA loc $ do + (ds', tvs) <- tc_deriv_strategy ds + pure (Just (L loc ds'), tvs) + where + tc_deriv_strategy :: DerivStrategy GhcRn + -> TcM (DerivStrategy GhcTc, [TyVar]) + tc_deriv_strategy (StockStrategy _) = boring_case (StockStrategy noExtField) + tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField) + tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField) + tc_deriv_strategy (ViaStrategy hs_sig) + = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig + ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty} + ; pure (ViaStrategy via_pred, via_tvs) } + + boring_case :: ds -> TcM (ds, [a]) + boring_case ds = pure (ds, []) + +tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt + -> LHsSigType GhcRn + -> TcM Type +-- Like tcHsSigType, but for a class instance declaration +tcHsClsInstType user_ctxt hs_inst_ty + = setSrcSpan (getLocA hs_inst_ty) $ + do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty + ; checkValidInstance user_ctxt hs_inst_ty inst_ty + ; return inst_ty } + +---------------------------------------------- +-- | Type-check a visible type application +tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcHsTypeApp wc_ty kind + | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty + = do { mode <- mkHoleMode TypeLevel HM_VTA + -- HM_VTA: See Note [Wildcards in visible type application] + ; ty <- addTypeCtxt hs_ty $ + solveEqualities "tcHsTypeApp" $ + -- We are looking at a user-written type, very like a + -- signature so we want to solve its equalities right now + bindNamedWildCardBinders sig_wcs $ \ _ -> + tc_lhs_type mode hs_ty kind + + -- We do not kind-generalize type applications: we just + -- instantiate with exactly what the user says. + -- See Note [No generalization in type application] + -- We still must call kindGeneralizeNone, though, according + -- to Note [Recipe for checking a signature] + ; kindGeneralizeNone ty + ; ty <- zonkTcType ty + ; checkValidType TypeAppCtxt ty + ; return ty } + +{- Note [Wildcards in visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so +any unnamed wildcards stay unchanged in hswc_body. When called in +tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole +on these anonymous wildcards. However, this would trigger +error/warning when an anonymous wildcard is passed in as a visible type +argument, which we do not want because users should be able to write +@_ to skip a instantiating a type variable variable without fuss. The +solution is to switch the PartialTypeSignatures flags here to let the +typechecker know that it's checking a '@_' and do not emit hole +constraints on it. See related Note [Wildcards in visible kind +application] and Note [The wildcard story for types] in GHC.Hs.Type + +Ugh! + +Note [No generalization in type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not kind-generalize type applications. Imagine + + id @(Proxy Nothing) + +If we kind-generalized, we would get + + id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) + +which is very sneakily impredicative instantiation. + +There is also the possibility of mentioning a wildcard +(`id @(Proxy _)`), which definitely should not be kind-generalized. + +-} + +tcFamTyPats :: TyCon + -> HsTyPats GhcRn -- Patterns + -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) +-- Check the LHS of a type/data family instance +-- e.g. type instance F ty1 .. tyn = ... +-- Used for both type and data families +tcFamTyPats fam_tc hs_pats + = do { traceTc "tcFamTyPats {" $ + vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] + + ; mode <- mkHoleMode TypeLevel HM_FamPat + -- HM_FamPat: See Note [Wildcards in family instances] in + -- GHC.Rename.Module + ; let fun_ty = mkTyConApp fam_tc [] + ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats + + -- Hack alert: see Note [tcFamTyPats: zonking the result kind] + ; res_kind <- zonkTcType res_kind + + ; traceTc "End tcFamTyPats }" $ + vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] + + ; return (fam_app, res_kind) } + where + fam_name = tyConName fam_tc + fam_arity = tyConArity fam_tc + lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name)) + +{- Note [tcFamTyPats: zonking the result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19250) + F :: forall k. k -> k + type instance F (x :: Constraint) = () + +The tricky point is this: + is that () an empty type tuple (() :: Type), or + an empty constraint tuple (() :: Constraint)? +We work this out in a hacky way, by looking at the expected kind: +see Note [Inferring tuple kinds]. + +In this case, we kind-check the RHS using the kind gotten from the LHS: +see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. + +But we want the kind from the LHS to be /zonked/, so that when +kind-checking the RHS (tcCheckLHsType) we can "see" what we learned +from kind-checking the LHS (tcFamTyPats). In our example above, the +type of the LHS is just `kappa` (by instantiating the forall k), but +then we learn (from x::Constraint) that kappa ~ Constraint. We want +that info when kind-checking the RHS. + +Easy solution: just zonk that return kind. Of course this won't help +if there is lots of type-family reduction to do, but it works fine in +common cases. +-} + + +{- +************************************************************************ +* * + The main kind checker: no validity checks here +* * +************************************************************************ +-} + +--------------------------- +tcHsOpenType, tcHsLiftedType, + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty +tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty + +tcHsOpenTypeNC hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek } +tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + do { ek <- newExpectedKind exp_kind + ; tcLHsType hs_ty ek } + +tcInferLHsType :: LHsType GhcRn -> TcM TcType +tcInferLHsType hs_ty + = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty + ; return ty } + +tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) +-- Called from outside: set the context +-- Eagerly instantiate any trailing invisible binders +tcInferLHsTypeKind lhs_ty@(L loc hs_ty) + = addTypeCtxt lhs_ty $ + setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders + do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty + ; tcInstInvisibleTyBinders res_ty res_kind } + -- See Note [Do not always instantiate eagerly in types] + +-- Used to check the argument of GHCi :kind +-- Allow and report wildcards, e.g. :kind T _ +-- Do not saturate family applications: see Note [Dealing with :kind] +-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types] +tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) +tcInferLHsTypeUnsaturated hs_ty + = addTypeCtxt hs_ty $ + do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes + ; case splitHsAppTys (unLoc hs_ty) of + Just (hs_fun_ty, hs_args) + -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty + ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args } + -- Notice the 'nosat'; do not instantiate trailing + -- invisible arguments of a type family. + -- See Note [Dealing with :kind] + Nothing -> tc_infer_lhs_type mode hs_ty } + +{- Note [Dealing with :kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi command + ghci> type family F :: Either j k + ghci> :kind F + F :: forall {j,k}. Either j k + +We will only get the 'forall' if we /refrain/ from saturating those +invisible binders. But generally we /do/ saturate those invisible +binders (see tcInferTyApps), and we want to do so for nested application +even in GHCi. Consider for example (#16287) + ghci> type family F :: k + ghci> data T :: (forall k. k) -> Type + ghci> :kind T F +We want to reject this. It's just at the very top level that we want +to switch off saturation. + +So tcInferLHsTypeUnsaturated does a little special case for top level +applications. Actually the common case is a bare variable, as above. + +Note [Do not always instantiate eagerly in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Terms are eagerly instantiated. This means that if you say + + x = id + +then `id` gets instantiated to have type alpha -> alpha. The variable +alpha is then unconstrained and regeneralized. But we cannot do this +in types, as we have no type-level lambda. So, when we are sure +that we will not want to regeneralize later -- because we are done +checking a type, for example -- we can instantiate. But we do not +instantiate at variables, nor do we in tcInferLHsTypeUnsaturated, +which is used by :kind in GHCi. + +************************************************************************ +* * + Type-checking modes +* * +************************************************************************ + +The kind-checker is parameterised by a TcTyMode, which contains some +information about where we're checking a type. + +The renamer issues errors about what it can. All errors issued here must +concern things that the renamer can't handle. + +-} + +tcMult :: HsArrow GhcRn -> TcM Mult +tcMult hc = tc_mult typeLevelMode hc + +-- | Info about the context in which we're checking a type. Currently, +-- differentiates only between types and kinds, but this will likely +-- grow, at least to include the distinction between patterns and +-- not-patterns. +-- +-- To find out where the mode is used, search for 'mode_tyki' +-- +-- This data type is purely local, not exported from this module +data TcTyMode + = TcTyMode { mode_tyki :: TypeOrKind + , mode_holes :: HoleInfo } + +-- See Note [Levels for wildcards] +-- Nothing <=> no wildcards expected +type HoleInfo = Maybe (TcLevel, HoleMode) + +-- HoleMode says how to treat the occurrences +-- of anonymous wildcards; see tcAnonWildCardOcc +data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int + | HM_FamPat -- Family instances: F _ Int = Bool + | HM_VTA -- Visible type and kind application: + -- f @(Maybe _) + -- Maybe @(_ -> _) + | HM_TyAppPat -- Visible type applications in patterns: + -- foo (Con @_ @t x) = ... + -- case x of Con @_ @t v -> ... + +mkMode :: TypeOrKind -> TcTyMode +mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing } + +typeLevelMode, kindLevelMode :: TcTyMode +-- These modes expect no wildcards (holes) in the type +kindLevelMode = mkMode KindLevel +typeLevelMode = mkMode TypeLevel + +mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode +mkHoleMode tyki hm + = do { lvl <- getTcLevel + ; return (TcTyMode { mode_tyki = tyki + , mode_holes = Just (lvl,hm) }) } + +instance Outputable HoleMode where + ppr HM_Sig = text "HM_Sig" + ppr HM_FamPat = text "HM_FamPat" + ppr HM_VTA = text "HM_VTA" + ppr HM_TyAppPat = text "HM_TyAppPat" + +instance Outputable TcTyMode where + ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm }) + = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma + , ppr hm ]) + +{- +Note [Bidirectional type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In expressions, whenever we see a polymorphic identifier, say `id`, we are +free to instantiate it with metavariables, knowing that we can always +re-generalize with type-lambdas when necessary. For example: + + rank2 :: (forall a. a -> a) -> () + x = rank2 id + +When checking the body of `x`, we can instantiate `id` with a metavariable. +Then, when we're checking the application of `rank2`, we notice that we really +need a polymorphic `id`, and then re-generalize over the unconstrained +metavariable. + +In types, however, we're not so lucky, because *we cannot re-generalize*! +There is no lambda. So, we must be careful only to instantiate at the last +possible moment, when we're sure we're never going to want the lost polymorphism +again. This is done in calls to tcInstInvisibleTyBinders. + +To implement this behavior, we use bidirectional type checking, where we +explicitly think about whether we know the kind of the type we're checking +or not. Note that there is a difference between not knowing a kind and +knowing a metavariable kind: the metavariables are TauTvs, and cannot become +forall-quantified kinds. Previously (before dependent types), there were +no higher-rank kinds, and so we could instantiate early and be sure that +no types would have polymorphic kinds, and so we could always assume that +the kind of a type was a fresh metavariable. Not so anymore, thus the +need for two algorithms. + +For HsType forms that can never be kind-polymorphic, we implement only the +"down" direction, where we safely assume a metavariable kind. For HsType forms +that *can* be kind-polymorphic, we implement just the "up" (functions with +"infer" in their name) version, as we gain nothing by also implementing the +"down" version. + +Note [Future-proofing the type checker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As discussed in Note [Bidirectional type checking], each HsType form is +handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions +are mutually recursive, so that either one can work for any type former. +But, we want to make sure that our pattern-matches are complete. So, +we have a bunch of repetitive code just so that we get warnings if we're +missing any patterns. + +-} + +------------------------------------------ +-- | Check and desugar a type, returning the core type and its +-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression +-- level. +tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +tc_infer_lhs_type mode (L span ty) + = setSrcSpanA span $ + tc_infer_hs_type mode ty + +--------------------------- +-- | Call 'tc_infer_hs_type' and check its result against an expected kind. +tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +tc_infer_hs_type_ek mode hs_ty ek + = do { (ty, k) <- tc_infer_hs_type mode hs_ty + ; checkExpectedKind hs_ty ty k ek } + +--------------------------- +-- | Infer the kind of a type and desugar. This is the "up" type-checker, +-- as described in Note [Bidirectional type checking] +tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) + +tc_infer_hs_type mode (HsParTy _ t) + = tc_infer_lhs_type mode t + +tc_infer_hs_type mode ty + | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty + = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty + ; tcInferTyApps mode hs_fun_ty fun_ty hs_args } + +tc_infer_hs_type mode (HsKindSig _ ty sig) + = do { let mode' = mode { mode_tyki = KindLevel } + ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig + -- We must typecheck the kind signature, and solve all + -- its equalities etc; from this point on we may do + -- things like instantiate its foralls, so it needs + -- to be fully determined (#14904) + ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig') + ; ty' <- tc_lhs_type mode ty sig' + ; return (ty', sig') } + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate +-- the splice location to the typechecker. Here we skip over it in order to have +-- the same kind inferred for a given expression whether it was produced from +-- splices or not. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) + = tc_infer_hs_type mode ty + +tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty + +-- See Note [Typechecking HsCoreTys] +tc_infer_hs_type _ (XHsType ty) + = do env <- getLclEnv + -- Raw uniques since we go from NameEnv to TvSubstEnv. + let subst_prs :: [(Unique, TcTyVar)] + subst_prs = [ (getUnique nm, tv) + | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] + subst = mkTvSubst + (mkInScopeSet $ mkVarSet $ map snd subst_prs) + (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) + ty' = substTy subst ty + return (ty', tcTypeKind ty') + +tc_infer_hs_type _ (HsExplicitListTy _ _ tys) + | null tys -- this is so that we can use visible kind application with '[] + -- e.g ... '[] @Bool + = return (mkTyConTy promotedNilDataCon, + mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) + +tc_infer_hs_type mode other_ty + = do { kv <- newMetaKindVar + ; ty' <- tc_hs_type mode other_ty kv + ; return (ty', kv) } + +{- +Note [Typechecking HsCoreTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. +As such, there's not much to be done in order to typecheck an HsCoreTy, +since it's already been typechecked to some extent. There is one thing that +we must do, however: we must substitute the type variables from the tcl_env. +To see why, consider GeneralizedNewtypeDeriving, which is one of the main +clients of HsCoreTy (example adapted from #14579): + + newtype T a = MkT a deriving newtype Eq + +This will produce an InstInfo GhcPs that looks roughly like this: + + instance forall a_1. Eq a_1 => Eq (T a_1) where + (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an HsCoreTy + @(T a_1 -> T a_1 -> Bool) -- So is this + (==) + +This is then fed into the renamer. Since all of the type variables in this +InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically +identical. Things get more interesting when the InstInfo is fed into the +typechecker, however. GHC will first generate fresh skolems to instantiate +the instance-bound type variables with. In the example above, we might generate +the skolem a_2 and use that to instantiate a_1, which extends the local type +environment (tcl_env) with [a_1 :-> a_2]. This gives us: + + instance forall a_2. Eq a_2 => Eq (T a_2) where ... + +To ensure that the body of this instance is well scoped, every occurrence of +the `a` type variable should refer to a_2, the new skolem. However, the +HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the +substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this +substitution to each HsCoreTy and all is well: + + instance forall a_2. Eq a_2 => Eq (T a_2) where + (==) = coerce @( a_2 -> a_2 -> Bool) + @(T a_2 -> T a_2 -> Bool) + (==) +-} + +------------------------------------------ +tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType +tcLHsType hs_ty exp_kind + = tc_lhs_type typeLevelMode hs_ty exp_kind + +tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType +tc_lhs_type mode (L span ty) exp_kind + = setSrcSpanA span $ + tc_hs_type mode ty exp_kind + +tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType +-- See Note [Bidirectional type checking] + +tc_hs_type mode (HsParTy _ ty) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind +tc_hs_type _ ty@(HsBangTy _ bang _) _ + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210, #14761) + = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation cannot appear nested inside a type" + ; case bang of + HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" + HsSrcBang _ _ _ -> bangError "strictness" } +tc_hs_type _ ty@(HsRecTy {}) _ + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Record syntax is illegal here:" <+> ppr ty) + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. +-- Here we get rid of it and add the finalizers to the global environment +-- while capturing the local environment. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tc_hs_type mode ty exp_kind + +-- This should never happen; type splices are expanded by the renamer +tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (text "Unexpected type splice:" <+> ppr ty) + +---------- Functions and applications +tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind + = tc_fun_type mode mult ty1 ty2 exp_kind + +tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind + | op `hasKey` funTyConKey + = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind + +--------- Foralls +tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind + = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ + tc_lhs_type mode ty exp_kind + -- Pass on the mode from the type, to any wildcards + -- in kind signatures on the forall'd variables + -- e.g. f :: _ -> Int -> forall (a :: _). blah + -- Why exp_kind? See Note [Body kind of HsForAllTy] + + -- Do not kind-generalise here! See Note [Kind generalisation] + + ; return (mkForAllTys tv_bndrs ty') } + +tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind + | null (unLoc ctxt) + = tc_lhs_type mode rn_ty exp_kind + + -- See Note [Body kind of a HsQualTy] + | tcIsConstraintKind exp_kind + = do { ctxt' <- tc_hs_context mode ctxt + ; ty' <- tc_lhs_type mode rn_ty constraintKind + ; return (mkPhiTy ctxt' ty') } + + | otherwise + = do { ctxt' <- tc_hs_context mode ctxt + + ; ek <- newOpenTypeKind -- The body kind (result of the function) can + -- be TYPE r, for any r, hence newOpenTypeKind + ; ty' <- tc_lhs_type mode rn_ty ek + ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty') + liftedTypeKind exp_kind } + +--------- Lists, arrays, and tuples +tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind + ; checkWiredInTyCon listTyCon + ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } + +-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type +-- See Note [Inferring tuple kinds] +tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | Just tup_sort <- tupKindSort_maybe exp_kind + = traceTc "tc_hs_type tuple" (ppr hs_tys) >> + tc_tuple rn_ty mode tup_sort hs_tys exp_kind + | otherwise + = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) + ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys + ; kinds <- mapM zonkTcType kinds + -- Infer each arg type separately, because errors can be + -- confusing if we give them a shared kind. Eg #7410 + -- (Either Int, Int), we do not want to get an error saying + -- "the second argument of a tuple should have kind *->*" + + ; let (arg_kind, tup_sort) + = case [ (k,s) | k <- kinds + , Just s <- [tupKindSort_maybe k] ] of + ((k,s) : _) -> (k,s) + [] -> (liftedTypeKind, BoxedTuple) + -- In the [] case, it's not clear what the kind is, so guess * + + ; tys' <- sequence [ setSrcSpanA loc $ + checkExpectedKind hs_ty ty kind arg_kind + | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] + + ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } + + +tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind + = tc_tuple rn_ty mode UnboxedTuple tys exp_kind + +tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind + = do { let arity = length hs_tys + ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys + ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds + ; let arg_reps = map kindRep arg_kinds + arg_tys = arg_reps ++ tau_tys + sum_ty = mkTyConApp (sumTyCon arity) arg_tys + sum_kind = unboxedSumKind arg_reps + ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind + } + +--------- Promoted lists and tuples +tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + = do { tks <- mapM (tc_infer_lhs_type mode) tys + ; (taus', kind) <- unifyKinds tys tks + ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') + ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } + where + mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] + +tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind + -- using newMetaKindVar means that we force instantiations of any polykinded + -- types. At first, I just used tc_infer_lhs_type, but that led to #11255. + = do { ks <- replicateM arity newMetaKindVar + ; taus <- zipWithM (tc_lhs_type mode) tys ks + ; let kind_con = tupleTyCon Boxed arity + ty_con = promotedTupleDataCon Boxed arity + tup_k = mkTyConApp kind_con ks + ; checkTupSize arity + ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + where + arity = length tys + +--------- Constraint types +tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind + = do { massert (isTypeLevel (mode_tyki mode)) + ; ty' <- tc_lhs_type mode ty liftedTypeKind + ; let n' = mkStrLitTy $ hsIPNameFS n + ; ipClass <- tcLookupClass ipClassName + ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) + constraintKind exp_kind } + +tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind + -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to + -- handle it in 'coreView' and 'tcView'. + = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind + +--------- Literals +tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon naturalTyCon + ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind } + +tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } +tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind + = do { checkWiredInTyCon charTyCon + ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind } + +--------- Wildcards + +tc_hs_type mode ty@(HsWildCardTy _) ek + = tcAnonWildCardOcc NoExtraConstraint mode ty ek + +--------- Potentially kind-polymorphic types: call the "up" checker +-- See Note [Future-proofing the type checker] +tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(XHsType {}) ek = tc_infer_hs_type_ek mode ty ek + +{- +Note [Variable Specificity and Forall Visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall +binder. Furthermore, each invisible type variable binder also has a +Specificity. Together, these determine the variable binders (ArgFlag) for each +variable in the generated ForAllTy type. + +This table summarises this relation: +---------------------------------------------------------------------------- +| User-written type HsForAllTelescope Specificity ArgFlag +|--------------------------------------------------------------------------- +| f :: forall a. type HsForAllInvis SpecifiedSpec Specified +| f :: forall {a}. type HsForAllInvis InferredSpec Inferred +| f :: forall a -> type HsForAllVis SpecifiedSpec Required +| f :: forall {a} -> type HsForAllVis InferredSpec / +| This last form is non-sensical and is thus rejected. +---------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ArgFlag, see +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +-} + +------------------------------------------ +tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult +tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy +------------------------------------------ +tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind + -> TcM TcType +tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of + TypeLevel -> + do { arg_k <- newOpenTypeKind + ; res_k <- newOpenTypeKind + ; ty1' <- tc_lhs_type mode ty1 arg_k + ; ty2' <- tc_lhs_type mode ty2 res_k + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + KindLevel -> -- no representation polymorphism in kinds. yet. + do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind + ; mult' <- tc_mult mode mult + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + +{- Note [Skolem escape and forall-types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Checking telescopes]. + +Consider + f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () + +The Proxy '[a,b] forces a and b to have the same kind. But a's +kind must be bound outside the 'forall a', and hence escapes. +We discover this by building an implication constraint for +each forall. So the inner implication constraint will look like + forall kb (b::kb). kb ~ ka +where ka is a's kind. We can't unify these two, /even/ if ka is +unification variable, because it would be untouchable inside +this inner implication. + +That's what the pushLevelAndCaptureConstraints, plus subsequent +buildTvImplication/emitImplication is all about, when kind-checking +HsForAllTy. + +Note that + +* We don't need to /simplify/ the constraints here + because we aren't generalising. We just capture them. + +* We can't use emitResidualTvConstraint, because that has a fast-path + for empty constraints. We can't take that fast path here, because + we must do the bad-telescope check even if there are no inner wanted + constraints. See Note [Checking telescopes] in + GHC.Tc.Types.Constraint. Lacking this check led to #16247. +-} + +{- ********************************************************************* +* * + Tuples +* * +********************************************************************* -} + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- tcView k = tupKindSort_maybe k' + | tcIsConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType +tc_tuple rn_ty mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (replicate arity liftedTypeKind) + UnboxedTuple -> replicateM arity newOpenTypeKind + ConstraintTuple -> return (replicate arity constraintKind) + ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds + ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } + where + arity = length tys + +finish_tuple :: HsType GhcRn + -> TupleSort + -> [TcType] -- ^ argument types + -> [TcKind] -- ^ of these kinds + -> TcKind -- ^ expected kind of the whole tuple + -> TcM TcType +finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do + traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) + case tup_sort of + ConstraintTuple + | [tau_ty] <- tau_tys + -- Drop any uses of 1-tuple constraints here. + -- See Note [Ignore unary constraint tuples] + -> check_expected_kind tau_ty constraintKind + | otherwise + -> do let tycon = cTupleTyCon arity + checkCTupSize arity + check_expected_kind (mkTyConApp tycon tau_tys) constraintKind + BoxedTuple -> do + let tycon = tupleTyCon Boxed arity + checkTupSize arity + checkWiredInTyCon tycon + check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind + UnboxedTuple -> do + let tycon = tupleTyCon Unboxed arity + tau_reps = map kindRep tau_kinds + -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + arg_tys = tau_reps ++ tau_tys + res_kind = unboxedTupleKind tau_reps + checkTupSize arity + check_expected_kind (mkTyConApp tycon arg_tys) res_kind + where + arity = length tau_tys + check_expected_kind ty act_kind = + checkExpectedKind rn_ty ty act_kind exp_kind + +{- +Note [Ignore unary constraint tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in +GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, +recall the definition of a unary tuple data type: + + data Solo a = Solo a + +Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and +lazy. Therefore, the presence of `Solo` matters semantically. On the other +hand, suppose we had a unary constraint tuple: + + class a => Solo% a + +This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is +semantically equivalent to `a`. Therefore, a 1-tuple constraint would have +no user-visible impact, nor would it allow you to express anything that +you couldn't otherwise. + +We could simply add Solo% for consistency with tuples (Solo) and unboxed +tuples (Solo#), but that would require even more magic to wire in another +magical class, so we opt not to do so. We must be careful, however, since +one can try to sneak in uses of unary constraint tuples through Template +Haskell, such as in this program (from #17511): + + f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] + (ConT ''String))) + -- f :: Solo% (Show Int) => String + f = "abc" + +This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, +and since it is used in a Constraint position, GHC will attempt to treat +it as thought it were a constraint tuple, which can potentially lead to +trouble if one attempts to look up the name of a constraint tuple of arity +1 (as it won't exist). To avoid this trouble, we simply take any unary +constraint tuples discovered when typechecking and drop them—i.e., treat +"Solo% a" as though the user had written "a". This is always safe to do +since the two constraints should be semantically equivalent. +-} + +{- ********************************************************************* +* * + Type applications +* * +********************************************************************* -} + +splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) +splitHsAppTys hs_ty + | is_app hs_ty = Just (go (noLocA hs_ty) []) + | otherwise = Nothing + where + is_app :: HsType GhcRn -> Bool + is_app (HsAppKindTy {}) = True + is_app (HsAppTy {}) = True + is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey) + -- I'm not sure why this funTyConKey test is necessary + -- Can it even happen? Perhaps for t1 `(->)` t2 + -- but then maybe it's ok to treat that like a normal + -- application rather than using the special rule for HsFunTy + is_app (HsTyVar {}) = True + is_app (HsParTy _ (L _ ty)) = is_app ty + is_app _ = False + + go :: LHsType GhcRn + -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)] + -> (LHsType GhcRn, + [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp + go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) + go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) + go (L _ (HsOpTy _ l op@(L sp _) r)) as + = ( L (na2la sp) (HsTyVar noAnn NotPromoted op) + , HsValArg l : HsValArg r : as ) + go f as = (f, as) + +--------------------------- +tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +-- Version of tc_infer_lhs_type specialised for the head of an +-- application. In particular, for a HsTyVar (which includes type +-- constructors, it does not zoom off into tcInferTyApps and family +-- saturation +tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv))) + = tcTyVar tv +tcInferTyAppHead mode ty + = tc_infer_lhs_type mode ty + +--------------------------- +-- | Apply a type of a given kind to a list of arguments. This instantiates +-- invisible parameters as necessary. Always consumes all the arguments, +-- using matchExpectedFunKind as necessary. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- +-- tcInferTyApps also arranges to saturate any trailing invisible arguments +-- of a type-family application, which is usually the right thing to do +-- tcInferTyApps_nosat does not do this saturation; it is used only +-- by ":kind" in GHCi +tcInferTyApps, tcInferTyApps_nosat + :: TcTyMode + -> LHsType GhcRn -- ^ Function (for printing only) + -> TcType -- ^ Function + -> [LHsTypeArg GhcRn] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, result kind) +tcInferTyApps mode hs_ty fun hs_args + = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args + ; saturateFamApp f_args res_k } + +tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args + = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) + ; (f_args, res_k) <- go_init 1 fun orig_hs_args + ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) + ; return (f_args, res_k) } + where + + -- go_init just initialises the auxiliary + -- arguments of the 'go' loop + go_init n fun all_args + = go n fun empty_subst fun_ki all_args + where + fun_ki = tcTypeKind fun + -- We do (tcTypeKind fun) here, even though the caller + -- knows the function kind, to absolutely guarantee + -- INVARIANT for 'go' + -- Note that in a typical application (F t1 t2 t3), + -- the 'fun' is just a TyCon, so tcTypeKind is fast + + empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType fun_ki + + go :: Int -- The # of the next argument + -> TcType -- Function applied to some args + -> TCvSubst -- Applies to function kind + -> TcKind -- Function kind + -> [LHsTypeArg GhcRn] -- Un-type-checked args + -> TcM (TcType, TcKind) -- Result type and its kind + -- INVARIANT: in any call (go n fun subst fun_ki args) + -- tcTypeKind fun = subst(fun_ki) + -- So the 'subst' and 'fun_ki' arguments are simply + -- there to avoid repeatedly calling tcTypeKind. + -- + -- Reason for INVARIANT: to support the Purely Kinded Type Invariant + -- it's important that if fun_ki has a forall, then so does + -- (tcTypeKind fun), because the next thing we are going to do + -- is apply 'fun' to an argument type. + + -- Dispatch on all_args first, for performance reasons + go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of + + ---------------- No user-written args left. We're done! + ([], _) -> return (fun, substTy subst fun_ki) + + ---------------- HsArgPar: We don't care about parens here + (HsArgPar _ : args, _) -> go n fun subst fun_ki args + + ---------------- HsTypeArg: a kind application (fun @ki) + (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> + case ki_binder of + + -- FunTy with PredTy on LHS, or ForAllTy with Inferred + Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki + Anon InvisArg _ -> instantiate ki_binder inner_ki + + Named (Bndr _ Specified) -> -- Visible kind application + do { traceTc "tcInferTyApps (vis kind app)" + (vcat [ ppr ki_binder, ppr hs_ki_arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + + ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; arg_mode <- mkHoleMode KindLevel HM_VTA + -- HM_VKA: see Note [Wildcards in visible kind application] + ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ + tc_lhs_type arg_mode hs_ki_arg exp_kind + + ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg + ; go (n+1) fun' subst' inner_ki hs_args } + + -- Attempted visible kind application (fun @ki), but fun_ki is + -- forall k -> blah or k1 -> k2 + -- So we need a normal application. Error. + _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki + + -- No binder; try applying the substitution, or fail if that's not possible + (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ + ty_app_err ki_arg substed_fun_ki + + ---------------- HsValArg: a normal argument (fun ty) + (HsValArg arg : args, Just (ki_binder, inner_ki)) + -- next binder is invisible; need to instantiate it + | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; + -- or ForAllTy with Inferred or Specified + -> instantiate ki_binder inner_ki + + -- "normal" case + | otherwise + -> do { traceTc "tcInferTyApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr arg + , ppr (tyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ + tc_lhs_type mode arg exp_kind + ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' + ; go (n+1) fun' subst' inner_ki args } + + -- no binder; try applying the substitution, or infer another arrow in fun kind + (HsValArg _ : _, Nothing) + -> try_again_after_substing_or $ + do { let arrows_needed = n_initial_val_args all_args + ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki + + ; fun' <- zonkTcType (fun `mkTcCastTy` co) + -- This zonk is essential, to expose the fruits + -- of matchExpectedFunKind to the 'go' loop + + ; traceTc "tcInferTyApps (no binder)" $ + vcat [ ppr fun <+> dcolon <+> ppr fun_ki + , ppr arrows_needed + , ppr co + , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] + ; go_init n fun' all_args } + -- Use go_init to establish go's INVARIANT + where + instantiate ki_binder inner_ki + = do { traceTc "tcInferTyApps (need to instantiate)" + (vcat [ ppr ki_binder, ppr subst]) + ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder + ; go n (mkAppTy fun arg') subst' inner_ki all_args } + -- Because tcInvisibleTyBinder instantiate ki_binder, + -- the kind of arg' will have the same shape as the kind + -- of ki_binder. So we don't need mkAppTyM here. + + try_again_after_substing_or fallthrough + | not (isEmptyTCvSubst subst) + = go n fun zapped_subst substed_fun_ki all_args + | otherwise + = fallthrough + + zapped_subst = zapTCvSubst subst + substed_fun_ki = substTy subst fun_ki + hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) + + n_initial_val_args :: [HsArg tm ty] -> Arity + -- Count how many leading HsValArgs we have + n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args + n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args + n_initial_val_args _ = 0 + + ty_app_err arg ty + = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + + +mkAppTyM :: TCvSubst + -> TcType -> TyCoBinder -- fun, plus its top-level binder + -> TcType -- arg + -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun arg) +-- Precondition: the application (fun arg) is well-kinded after zonking +-- That is, the application makes sense +-- +-- Precondition: for (mkAppTyM subst fun bndr arg) +-- tcTypeKind fun = Pi bndr. body +-- That is, fun always has a ForAllTy or FunTy at the top +-- and 'bndr' is fun's pi-binder +-- +-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type +-- invariant, then so does the result type (fun arg) +-- +-- We do not require that +-- tcTypeKind arg = tyVarKind (binderVar bndr) +-- This must be true after zonking (precondition 1), but it's not +-- required for the (PKTI). +mkAppTyM subst fun ki_binder arg + | -- See Note [mkAppTyM]: Nasty case 2 + TyConApp tc args <- fun + , isTypeSynonymTyCon tc + , args `lengthIs` (tyConArity tc - 1) + , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym + = do { arg' <- zonkTcType arg + ; args' <- zonkTcTypes args + ; let subst' = case ki_binder of + Anon {} -> subst + Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' + ; return (subst', mkTyConApp tc (args' ++ [arg'])) } + + +mkAppTyM subst fun (Anon {}) arg + = return (subst, mk_app_ty fun arg) + +mkAppTyM subst fun (Named (Bndr tv _)) arg + = do { arg' <- if isTrickyTvBinder tv + then -- See Note [mkAppTyM]: Nasty case 1 + zonkTcType arg + else return arg + ; return ( extendTvSubstAndInScope subst tv arg' + , mk_app_ty fun arg' ) } + +mk_app_ty :: TcType -> TcType -> TcType +-- This function just adds an ASSERT for mkAppTyM's precondition +mk_app_ty fun arg + = assertPpr (isPiTy fun_kind) + (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ + mkAppTy fun arg + where + fun_kind = tcTypeKind fun + +isTrickyTvBinder :: TcTyVar -> Bool +-- NB: isTrickyTvBinder is just an optimisation +-- It would be absolutely sound to return True always +isTrickyTvBinder tv = isPiTy (tyVarKind tv) + +{- Note [The Purely Kinded Type Invariant (PKTI)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type inference, we maintain this invariant + + (PKTI) It is legal to call 'tcTypeKind' on any Type ty, + on any sub-term of ty, /without/ zonking ty + + Moreover, any such returned kind + will itself satisfy (PKTI) + +By "legal to call tcTypeKind" we mean "tcTypeKind will not crash". +The way in which tcTypeKind can crash is in applications + (a t1 t2 .. tn) +if 'a' is a type variable whose kind doesn't have enough arrows +or foralls. (The crash is in piResultTys.) + +The loop in tcInferTyApps has to be very careful to maintain the (PKTI). +For example, suppose + kappa is a unification variable + We have already unified kappa := Type + yielding co :: Refl (Type -> Type) + a :: kappa +then consider the type + (a Int) +If we call tcTypeKind on that, we'll crash, because the (un-zonked) +kind of 'a' is just kappa, not an arrow kind. So we must zonk first. + +So the type inference engine is very careful when building applications. +This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), +where (a :: kappa). Then in tcInferApps we'll run out of binders on +a's kind, so we'll call matchExpectedFunKind, and unify + kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) +At this point we must zonk the function type to expose the arrrow, so +that (a Int) will satisfy (PKTI). + +The absence of this caused #14174 and #14520. + +The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. + +Wrinkle around FunTy: +Note that the PKTI does *not* guarantee anything about the shape of FunTys. +Specifically, when we have (FunTy vis mult arg res), it should be the case +that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we +might not have this. Example: if the user writes (a -> b), then we might +invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1 +(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2). +However, when we build the FunTy, we might not have zonked `a`, and so the +FunTy will be built without being able to purely extract the RuntimeReps. + +Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, +we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* +split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] +in GHC.Tc.Solver.Canonical. + +Note [mkAppTyM] +~~~~~~~~~~~~~~~ +mkAppTyM is trying to guarantee the Purely Kinded Type Invariant +(PKTI) for its result type (fun arg). There are two ways it can go wrong: + +* Nasty case 1: forall types (polykinds/T14174a) + T :: forall (p :: *->*). p Int -> p Bool + Now kind-check (T x), where x::kappa. + Well, T and x both satisfy the PKTI, but + T x :: x Int -> x Bool + and (x Int) does /not/ satisfy the PKTI. + +* Nasty case 2: type synonyms + type S f a = f a + Even though (S ff aa) would satisfy the (PKTI) if S was a data type + (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) + if S is a type synonym, because the /expansion/ of (S ff aa) is + (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps + (ff :: kappa), where 'kappa' has already been unified with (*->*). + + We check for nasty case 2 on the final argument of a type synonym. + +Notice that in both cases the trickiness only happens if the +bound variable has a pi-type. Hence isTrickyTvBinder. +-} + + +saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) +-- Precondition for (saturateFamApp ty kind): +-- tcTypeKind ty = kind +-- +-- If 'ty' is an unsaturated family application with trailing +-- invisible arguments, instantiate them. +-- See Note [saturateFamApp] + +saturateFamApp ty kind + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , mustBeSaturated tc + , let n_to_inst = tyConArity tc - length args + = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind + ; return (ty `mkTcAppTys` extra_args, ki') } + | otherwise + = return (ty, kind) + +{- Note [saturateFamApp] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: Either j k + type instance F @Type = Right Maybe + type instance F @Type = Right Either``` + +Then F :: forall {j,k}. Either j k + +The two type instances do a visible kind application that instantiates +'j' but not 'k'. But we want to end up with instances that look like + type instance F @Type @(*->*) = Right @Type @(*->*) Maybe + +so that F has arity 2. We must instantiate that trailing invisible +binder. In general, Invisible binders precede Specified and Required, +so this is only going to bite for apparently-nullary families. + +Note that + type family F2 :: forall k. k -> * +is quite different and really does have arity 0. + +It's not just type instances where we need to saturate those +unsaturated arguments: see #11246. Hence doing this in tcInferApps. +-} + +appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn +appTypeToArg f [] = f +appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg l arg : args) + = appTypeToArg (mkHsAppKindTy l f arg) args + + +{- ********************************************************************* +* * + checkExpectedKind +* * +********************************************************************* -} + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type +checkExpectedKind :: HasDebugCallStack + => HsType GhcRn -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind + -> TcM TcType +-- Just a convenience wrapper to save calls to 'ppr' +checkExpectedKind hs_ty ty act_kind exp_kind + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) + + ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just (HsTypeRnThing hs_ty) + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ ppr hs_ty + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; let res_ty = ty `mkTcAppTys` new_args + + ; if act_kind' `tcEqType` exp_kind + then return res_ty -- This is very common + else do { co_k <- uType KindLevel origin act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; return (res_ty `mkTcCastTy` co_k) } } + where + -- We need to make sure that both kinds have the same number of implicit + -- foralls out front. If the actual kind has more, instantiate accordingly. + -- Otherwise, just pass the type & kind through: the errors are caught + -- in unifyType. + n_exp_invis_bndrs = invisibleTyBndrCount exp_kind + n_act_invis_bndrs = invisibleTyBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + +--------------------------- + +tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] +tcHsContext Nothing = return [] +tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt + +tcLHsPredType :: LHsType GhcRn -> TcM PredType +tcLHsPredType pred = tc_lhs_pred typeLevelMode pred + +tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] +tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) + +tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType +tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind + +--------------------------- +tcTyVar :: Name -> TcM (TcType, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in GHC.Tc.TyCl +-- This does not instantiate. See Note [Do not always instantiate eagerly in types] +tcTyVar name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + -- See Note [Recursion through the kinds] + (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon + -> return (mkTyConTy tc, tyConKind tc) + + AGlobal (AConLike (RealDataCon dc)) + -> do { data_kinds <- xoptM LangExt.DataKinds + ; unless (data_kinds || specialPromotedDc dc) $ + promotionErr name NoDataKindsDC + ; when (isFamInstTyCon (dataConTyCon dc)) $ + -- see #15245 + promotionErr name FamDataConPE + ; let (_, _, _, theta, _, _) = dataConFullSig dc + ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta)) + ; case dc_theta_illegal_constraint theta of + Just pred -> promotionErr name $ + ConstrainedDataConPE pred + Nothing -> pure () + ; let tc = promoteDataCon dc + ; return (mkTyConApp tc [], tyConKind tc) } + + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr "type" thing name } + where + -- We cannot promote a data constructor with a context that contains + -- constraints other than equalities, so error if we find one. + -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep + dc_theta_illegal_constraint :: ThetaType -> Maybe PredType + dc_theta_illegal_constraint = find (not . isEqPred) + +{- +Note [Recursion through the kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these examples + +Ticket #11554: + data P (x :: k) = Q + data A :: Type where + MkA :: forall (a :: A). P a -> A + +Ticket #12174 + data V a + data T = forall (a :: T). MkT (V a) + +The type is recursive (which is fine) but it is recursive /through the +kinds/. In earlier versions of GHC this caused a loop in the compiler +(to do with knot-tying) but there is nothing fundamentally wrong with +the code (kinds are types, and the recursive declarations are OK). But +it's hard to distinguish "recursion through the kinds" from "recursion +through the types". Consider this (also #11554): + + data PB k (x :: k) = Q + data B :: Type where + MkB :: P B a -> B + +Here the occurrence of B is not obviously in a kind position. + +So now GHC allows all these programs. #12081 and #15942 are other +examples. + +Note [Body kind of a HsForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analysis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +It's tempting to check that the body kind is either * or #. But this is +wrong. For example: + + class C a b + newtype N = Mk Foo deriving (C a) + +We're doing newtype-deriving for C. But notice how `a` isn't in scope in +the predicate `C a`. So we quantify, yielding `forall a. C a` even though +`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but +convenient. Bottom line: don't check for * or # here. + +Note [Body kind of a HsQualTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ctxt is non-empty, the HsQualTy really is a /function/, so the +kind of the result really is '*', and in that case the kind of the +body-type can be lifted or unlifted. + +However, consider + instance Eq a => Eq [a] where ... +or + f :: (Eq a => Eq [a]) => blah +Here both body-kind of the HsQualTy is Constraint rather than *. +Rather crudely we tell the difference by looking at exp_kind. It's +very convenient to typecheck instance types like any other HsSigType. + +Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's +better to reject in checkValidType. If we say that the body kind +should be '*' we risk getting TWO error messages, one saying that Eq +[a] doesn't have kind '*', and one saying that we need a Constraint to +the left of the outer (=>). + +How do we figure out the right body kind? Well, it's a bit of a +kludge: I just look at the expected kind. If it's Constraint, we +must be in this instance situation context. It's a kludge because it +wouldn't work if any unification was involved to compute that result +kind -- but it isn't. (The true way might be to use the 'mode' +parameter, but that seemed like a sledgehammer to crack a nut.) + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the arguments to give good error messages in + e.g. (Maybe, Maybe) + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. + +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * It zonks any kinds. The returned type should have no mutable kind + or type variables (hence returning Type not TcType): + - any unconstrained kind variables are defaulted to (Any *) just + as in GHC.Tc.Utils.Zonk. + - there are no mutable type variables because we are + kind-checking a type + Reason: the returned type may be put in a TyCon or DataCon where + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to (Any *) when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as + (a) spurious ! annotations. + (b) a class used as a type + +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encounter the unconstrained kappa, we +want to default it to '*', not to (Any *). + +-} + +addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. + -- Omit invisible ones and ones user's won't grok +addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = text "In the type" <+> quotes (ppr ty) + + +{- ********************************************************************* +* * + Type-variable binders +* * +********************************************************************* -} + +bindNamedWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) + -> TcM a +-- Bring into scope the /named/ wildcard binders. Remember that +-- plain wildcards _ are anonymous and dealt with by HsWildCardTy +-- Soe Note [The wildcard story for types] in GHC.Hs.Type +bindNamedWildCardBinders wc_names thing_inside + = do { wcs <- mapM newNamedWildTyVar wc_names + ; let wc_prs = wc_names `zip` wcs + ; tcExtendNameTyVarEnv wc_prs $ + thing_inside wc_prs } + +newNamedWildTyVar :: Name -> TcM TcTyVar +-- ^ New unification variable '_' for a wildcard +newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type + = do { kind <- newMetaKindVar + ; details <- newMetaDetails TauTv + ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names] + ; let tyvar = mkTcTyVar wc_name kind details + ; traceTc "newWildTyVar" (ppr tyvar) + ; return tyvar } + +--------------------------- +tcAnonWildCardOcc :: IsExtraConstraint + -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) + ty exp_kind + -- hole_lvl: see Note [Checking partial type signatures] + -- esp the bullet on nested forall types + = do { kv_details <- newTauTvDetailsAtLevel hole_lvl + ; kv_name <- newMetaTyVarName (fsLit "k") + ; wc_details <- newTauTvDetailsAtLevel hole_lvl + ; wc_name <- newMetaTyVarName (fsLit wc_nm) + ; let kv = mkTcTyVar kv_name liftedTypeKind kv_details + wc_kind = mkTyVarTy kv + wc_tv = mkTcTyVar wc_name wc_kind wc_details + + ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) + ; when emit_holes $ + emitAnonTypeHole is_extra wc_tv + -- Why the 'when' guard? + -- See Note [Wildcards in visible kind application] + + -- You might think that this would always just unify + -- wc_kind with exp_kind, so we could avoid even creating kv + -- But the level numbers might not allow that unification, + -- so we have to do it properly (T14140a) + ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind } + where + -- See Note [Wildcard names] + wc_nm = case hole_mode of + HM_Sig -> "w" + HM_FamPat -> "_" + HM_VTA -> "w" + HM_TyAppPat -> "_" + + emit_holes = case hole_mode of + HM_Sig -> True + HM_FamPat -> False + HM_VTA -> False + HM_TyAppPat -> False + +tcAnonWildCardOcc _ mode ty _ +-- mode_holes is Nothing. Should not happen, because renamer +-- should already have rejected holes in unexpected places + = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty) + +{- Note [Wildcard names] +~~~~~~~~~~~~~~~~~~~~~~~~ +So we hackily use the mode_holes flag to control the name used +for wildcards: + +* For proper holes (whether in a visible type application (VTA) or no), + we rename the '_' to 'w'. This is so that we see variables like 'w0' + or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For + example, we prefer + Found type wildcard ‘_’ standing for ‘w0’ + over + Found type wildcard ‘_’ standing for ‘_1’ + + Even in the VTA case, where we do not emit an error to be printed, we + want to do the renaming, as the variables may appear in other, + non-wildcard error messages. + +* However, holes in the left-hand sides of type families ("type + patterns") stand for type variables which we do not care to name -- + much like the use of an underscore in an ordinary term-level + pattern. When we spot these, we neither wish to generate an error + message nor to rename the variable. We don't rename the variable so + that we can pretty-print a type family LHS as, e.g., + F _ Int _ = ... + and not + F w1 Int w2 = ... + + See also Note [Wildcards in family instances] in + GHC.Rename.Module. The choice of HM_FamPat is made in + tcFamTyPats. There is also some unsavory magic, relying on that + underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. + +Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how +would the typechecker know which '_' is being used in VKA and which is +not when it calls emitNamedTypeHole in +tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither +rename nor include unnamed wildcards in HsWildCardBndrs, but instead +give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. + +And whenever we see a '@', we set mode_holes to HM_VKA, so that +we do not call emitAnonTypeHole in tcAnonWildCardOcc. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in GHC.Hs.Type +-} + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck SAKS_or_CUSK + | InitialKindInfer + +-- Does the declaration have a standalone kind signature (SAKS) or a complete +-- user-specified kind (CUSK)? +data SAKS_or_CUSK + = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) + | CUSK -- Complete user-specified kind (CUSK) + +instance Outputable SAKS_or_CUSK where + ppr (SAKS k) = text "SAKS" <+> ppr k + ppr CUSK = text "CUSK" + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +kcDeclHeader + :: InitialKindStrategy + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon +kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig +kcDeclHeader InitialKindInfer = kcInferDeclHeader + +{- Note [kcCheckDeclHeader vs kcInferDeclHeader] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind +of a type constructor. + +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that + case, find the full, final, poly-kinded kind of the TyCon. It's very like a + term-level binding where we have a complete type signature for the function. + +* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a + CUSK. Find a monomorphic kind, with unification variables in it; they will be + generalised later. It's very like a term-level binding where we do not have a + type signature (or, more accurately, where we have a partial type signature), + so we infer the type and generalise. +-} + +------------------------------ +kcCheckDeclHeader + :: SAKS_or_CUSK + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig +kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk + +kcCheckDeclHeader_cusk + :: Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader_cusk name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- CUSK case + -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addTyConFlavCtxt name flav $ + do { skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ + bindImplicitTKBndrs_Q_Skol skol_info kv_ns $ + bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + + -- Now, because we're in a CUSK, + -- we quantify over the mentioned kind vars + ; let spec_req_tkvs = scoped_kvs ++ tc_tvs + all_kinds = res_kind : map tyVarKind spec_req_tkvs + + ; candidates <- candidateQTyVarsOfKinds all_kinds + -- 'candidates' are all the variables that we are going to + -- skolemise and then quantify over. We do not include spec_req_tvs + -- because they are /already/ skolems + + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $ + candidates `delCandidates` spec_req_tkvs + -- NB: 'inferred' comes back sorted in dependency order + + ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_tvs are skolems, + ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs -- so zonkTyCoVarKind suffices + ; res_kind <- zonkTcType res_kind + + ; let mentioned_kv_set = candidateKindVars candidates + specified = scopedSort scoped_kvs + -- NB: maintain the L-R order of scoped_kvs + + all_tcbs = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs + + -- Eta expand if necessary; we are building a PolyTyCon + ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind + + ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs + True -- it is generalised + flav + + ; reportUnsolvedEqualities skol_info (binderVars final_tcbs) + tclvl wanted + + -- If the ordering from + -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + -- doesn't work, we catch it here, before an error cascade + ; checkTyConTelescope tycon + + ; traceTc "kcCheckDeclHeader_cusk " $ + vcat [ text "name" <+> ppr name + , text "candidates" <+> ppr candidates + , text "mentioned_kv_set" <+> ppr mentioned_kv_set + , text "kv_ns" <+> ppr kv_ns + , text "hs_tvs" <+> ppr hs_tvs + , text "scoped_kvs" <+> ppr scoped_kvs + , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs + , text "all_kinds" <+> ppr all_kinds + , text "tc_tvs" <+> pprTyVars tc_tvs + , text "res_kind" <+> ppr res_kind + , text "inferred" <+> ppr inferred + , text "specified" <+> ppr specified + , text "final_tcbs" <+> ppr final_tcbs + , text "mkTyConKind final_tc_bndrs res_kind" + <+> ppr (mkTyConKind final_tcbs res_kind) + , text "all_tv_prs" <+> ppr all_tv_prs ] + + ; return tycon } + where + skol_info_anon = TyConSkol flav name + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and +-- other kinds). +-- +-- This function does not do telescope checking. +kcInferDeclHeader + :: Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn + -> TcM ContextKind -- ^ The result kind + -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon +kcInferDeclHeader name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- No standalane kind signature and no CUSK. + -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addTyConFlavCtxt name flav $ + do { (scoped_kvs, (tc_tvs, res_kind)) + -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + <- bindImplicitTKBndrs_Q_Tv kv_ns $ + bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + -- Why "_Tv" not "_Skol"? See third wrinkle in + -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, + + ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they + -- might unify with kind vars in other types in a mutually + -- recursive group. + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + + tc_binders = mkAnonTyConBinders VisArg tc_tvs + -- Also, note that tc_binders has the tyvars from only the + -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] + -- in GHC.Tc.TyCl + -- + -- mkAnonTyConBinder: see Note [No polymorphic recursion] + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + -- NB: bindExplicitTKBndrs_Q_Tv does not clone; + -- ditto Implicit + -- See Note [Cloning for type variable binders] + + tycon = mkTcTyCon name tc_binders res_kind all_tv_prs + False -- not yet generalised + flav + + ; traceTc "kcInferDeclHeader: not-cusk" $ + vcat [ ppr name, ppr kv_ns, ppr hs_tvs + , ppr scoped_kvs + , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Kind-check a declaration header against a standalone kind signature. +-- See Note [kcCheckDeclHeader_sig] +kcCheckDeclHeader_sig + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked + -> TyConFlavour -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon +-- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): +-- kind(returned PolyTcTyCon) = sig_kind +-- +kcCheckDeclHeader_sig sig_kind name flav + (HsQTvs { hsq_ext = implicit_nms + , hsq_explicit = hs_tv_bndrs }) kc_res_ki + = addTyConFlavCtxt name flav $ + do { skol_info <- mkSkolemInfo (TyConSkol flav name) + ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind) + <- splitTyConKind skol_info emptyInScopeSet + (map getOccName hs_tv_bndrs) sig_kind + + ; traceTc "kcCheckDeclHeader_sig {" $ + vcat [ text "sig_kind:" <+> ppr sig_kind + , text "sig_tcbs:" <+> ppr sig_tcbs + , text "sig_res_kind:" <+> ppr sig_res_kind ] + + ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind)))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 + bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone + matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> + do { -- 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 + + -- Work out extra_arity, the number of extra invisible binders from + -- the kind signature that should be part of the TyCon's arity. + -- See Note [Arity inference in kcCheckDeclHeader_sig] + ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs + invis_arity = case ctx_k of + AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders + -- the signature into part of the arity of the TyCon + OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the + -- invisible binders part of the arity of the TyCon + TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki) + + ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs + ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind + + ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs + , ppr invis_arity, ppr invis_tcbs + , ppr n_invis_tcbs ] + + -- Unify res_ki (from the type declaration) with the residual kind from + -- the kind signature. Don't forget to apply the skolemising 'subst' first. + ; case ctx_k of + AnyKind -> return () -- No signature + _ -> do { res_ki <- newExpectedKind ctx_k + ; discardResult (unifyKind Nothing sig_res_kind' res_ki) } + + -- Add more binders for data/newtype, so the result kind has no arrows + -- See Note [Datatype return kinds] + ; if null resid_tcbs || not (needsEtaExpansion flav) + then return (invis_tcbs, sig_res_kind') + else return (excess_sig_tcbs, sig_res_kind) + } + + + -- Check that there are no unsolved equalities + ; let all_tcbs = skol_tcbs ++ extra_tcbs + ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted + + -- Check that distinct binders map to distinct tyvars (see #20916). For example + -- type T :: k -> k -> Type + -- data T (a::p) (b::q) = ... + -- Here p and q both map to the same kind variable k. We don't allow this + -- so we must check that they are distinct. A similar thing happens + -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. + ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs + ; let implicit_prs = implicit_nms `zip` implicit_tvs + ; checkForDuplicateScopedTyVars implicit_prs + + -- Swizzle the Names so that the TyCon uses the user-declared implicit names + -- E.g type T :: k -> Type + -- data T (a :: j) = .... + -- We want the TyConBinders of T to be [j, a::j], not [k, a::k] + -- Why? So that the TyConBinders of the TyCon will lexically scope over the + -- associated types and methods of a class. + ; let swizzle_env = mkVarEnv (map swap implicit_prs) + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptyTCvSubst all_tcbs + swizzled_kind = substTy subst tycon_res_kind + all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) + + ; traceTc "kcCheckDeclHeader swizzle" $ vcat + [ text "implicit_prs = " <+> ppr implicit_prs + , text "implicit_nms = " <+> ppr implicit_nms + , text "hs_tv_bndrs = " <+> ppr hs_tv_bndrs + , text "all_tcbs = " <+> pprTyVars (binderVars all_tcbs) + , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs) + , text "tycon_res_kind =" <+> ppr tycon_res_kind + , text "swizzled_kind =" <+> ppr swizzled_kind ] + + -- Build the final, generalized PolyTcTyCon + -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs + -- because the tv_prs is used when (say) typechecking the RHS of + -- a type synonym. + ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav + + ; traceTc "kcCheckDeclHeader_sig }" $ vcat + [ text "tyConName = " <+> ppr (tyConName tc) + , text "sig_kind =" <+> debugPprType sig_kind + , text "tyConKind =" <+> debugPprType (tyConKind tc) + , text "tyConBinders = " <+> ppr (tyConBinders tc) + , text "tyConResKind" <+> debugPprType (tyConResKind tc) + ] + ; return tc } + +matchUpSigWithDecl + :: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature + -> TcKind -- The tail end of the kind signature + -> [LHsTyVarBndr () GhcRn] -- User-written binders in decl + -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope + -- Argument is excess TyConBinders and tail kind + -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars + , a ) +-- See Note [Matching a kind sigature with a declaration] +-- Invariant: Length of returned TyConBinders + length of excess TyConBinders +-- = length of incoming TyConBinders +matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside + = go emptyTCvSubst sig_tcbs hs_bndrs + where + go subst tcbs [] + = do { let (subst', tcbs') = substTyConBindersX subst tcbs + ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) + ; return ([], res) } + + go _ [] hs_bndrs + = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs) + + go subst (tcb : tcbs') hs_bndrs + | Bndr tv vis <- tcb + , isVisibleTcbVis vis + , (L _ hs_bndr : hs_bndrs') <- hs_bndrs -- hs_bndrs is non-empty + = -- Visible TyConBinder, so match up with the hs_bndrs + do { let tv' = updateTyVarKind (substTy subst) $ + setTyVarName tv (getName hs_bndr) + -- Give the skolem the Name of the HsTyVarBndr, so that if it + -- appears in an error message it has a name and binding site + -- that come from the type declaration, not the kind signature + subst' = extendTCvSubstWithClone subst tv tv' + ; tc_hs_bndr hs_bndr (tyVarKind tv') + ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $ + go subst' tcbs' hs_bndrs' + ; return (Bndr tv' vis : tcbs', res) } + + | otherwise + = -- Invisible TyConBinder, so do not consume one of the hs_bndrs + do { let (subst', tcb') = substTyConBinderX subst tcb + ; (tcbs', res) <- go subst' tcbs' hs_bndrs + -- NB: pass on hs_bndrs unchanged; we do not consume a + -- HsTyVarBndr for an invisible TyConBinder + ; return (tcb' : tcbs', res) } + + tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM () + tc_hs_bndr (UserTyVar _ _ _) _ + = return () + tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind + = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind + ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] + unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } + +substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +substTyConBinderX subst (Bndr tv vis) + = (subst', Bndr tv' vis) + where + (subst', tv') = substTyVarBndr subst tv + +substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder]) +substTyConBindersX = mapAccumL substTyConBinderX + +swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +swizzleTcb swizzle_env subst (Bndr tv vis) + = (subst', Bndr tv2 vis) + where + subst' = extendTCvSubstWithClone subst tv tv2 + tv1 = updateTyVarKind (substTy subst) tv + tv2 = case lookupVarEnv swizzle_env tv of + Just user_name -> setTyVarName tv1 user_name + Nothing -> tv1 + -- NB: the SrcSpan on an implicitly-bound name deliberately spans + -- the whole declaration. e.g. + -- data T (a :: k) (b :: Type -> k) = .... + -- There is no single binding site for 'k'. + -- See Note [Source locations for implicitly bound type variables] + -- in GHC.Tc.Rename.HsType + +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage +tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + +{- See Note [kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a kind signature 'sig_kind' and a declaration header, +kcCheckDeclHeader_sig verifies that the declaration conforms to the +signature. The end result is a PolyTcTyCon 'tc' such that: + tyConKind tc == sig_kind + +Basic plan is this: + * splitTyConKind: Take the Kind from the separate kind signature, and + decompose it all the way to a [TyConBinder] and a Kind in the corner. + + NB: these TyConBinders contain TyVars, not TcTyVars. + + * matchUpSigWithDecl: match the [TyConBinder] from the signature with + the [LHsTyVarBndr () GhcRn] from the declaration. The latter are the + explicit, user-written binders. e.g. + data T (a :: k) b = .... + There may be more of the former than the latter, because the former + include invisible binders. matchUpSigWithDecl uses isVisibleTcbVis + to decide which TyConBinders are visible. + + * matchUpSigWithDecl also skolemises the [TyConBinder] to produce + a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder]. + Each new TyConBinder + - Uses the Name from the LHsTyVarBndr, if available, both because that's + what the user expects, and because the binding site accurately comes + from the data/type declaration. + - Uses a skolem TcTyVar. We need these to allow unification. + + * machUpSigWithDecl also unifies the user-supplied kind signature for each + LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming + from the separate kind signature). + + * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate + signature with the kind signature (if any) in the data/type declaration. + E.g. + type S :: forall k. k -> k -> Type + type family S (a :: j) :: j -> Type + Here we match up the 'k ->' with (a :: j); and then must unify the leftover + part of the signature (k -> Type) with the kind signature of the decl, + (j -> Type). This unification, done in kcCheckDeclHeader, needs TcTyVars. + + * The tricky extra_arity part is described in + Note [Arity inference in kcCheckDeclHeader_sig] + +Note [Arity inference in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these declarations: + type family S1 :: forall k2. k1 -> k2 -> Type + type family S2 (a :: k1) (b :: k2) :: Type + +Both S1 and S2 can be given the same standalone kind signature: + type S1 :: forall k1 k2. k1 -> k2 -> Type + type S2 :: forall k1 k2. k1 -> k2 -> Type + +And, indeed, tyConKind S1 == tyConKind S2. However, +tyConBinders and tyConResKind for S1 and S2 are different: + + tyConBinders S1 == [spec k1] + tyConResKind S1 == forall k2. k1 -> k2 -> Type + tyConKind S1 == forall k1 k2. k1 -> k2 -> Type + + tyConBinders S2 == [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)] + tyConResKind S2 == Type + tyConKind S1 == forall k1 k2. k1 -> k2 -> Type + +This difference determines the /arity/: + tyConArity tc == length (tyConBinders tc) +That is, the arity of S1 is 1, while the arity of S2 is 4. + +'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the +standalone kind signature into binders and the result kind. It does so +in two rounds: + +1. matchUpSigWithDecl matches up + - the [TyConBinder] from (applying splitTyConKind to) the kind signature + - with the [LHsTyVarBndr] from the type declaration. + That may leave some excess TyConBinder: in the case of S2 there are + no excess TyConBinders, but in the case of S1 there are two (since + there are no LHsTYVarBndrs. + +2. Split off further TyConBinders (in the case of S1, one more) to + make it possible to unify the residual return kind with the + signature in the type declaration. More precisely, split off such + enough invisible that the remainder of the standalone kind + signature and the user-written result kind signature have the same + number of invisible quantifiers. + +As another example consider the following declarations: + + type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family F a b + + type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type + type family G a b :: forall r2. (r1, r2) -> Type + +For both F and G, the signature (after splitTyConKind) has + sig_tcbs :: [TyConBinder] + = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA)) + , spec (@k1_auB), spec (@k2_auC) + , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] + +matchUpSigWithDecl will consume the first three of these, passing on + excess_sig_tcbs + = [ spec (@k1_auB), spec (@k2_auC) + , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] + +For F, there is no result kind signature in the declaration for F, so +we absorb all invisible binders into F's arity. The resulting arity of +F is 3+2=5. + +Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'. +This has one invisible binder, so we split of enough extra binders from +our excess_sig_tcbs to leave just one to match 'r2'. + + res_ki = forall r2. (r1, r2) -> Type + kisig = forall k1 k2. (k1, k2) -> Type + ^^^ + split off this one. + +The resulting arity of G is 3+1=4. + +Note [discardResult in kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use 'unifyKind' to check inline kind annotations in declaration headers +against the signature. + + type T :: [i] -> Maybe j -> Type + data T (a :: [k1]) (b :: Maybe k2) :: Type where ... + +Here, we will unify: + + [k1] ~ [i] + Maybe k2 ~ Maybe j + Type ~ Type + +The end result is that we fill in unification variables k1, k2: + + k1 := i + k2 := j + +We also validate that the user isn't confused: + + type T :: Type -> Type + data T (a :: Bool) = ... + +This will report that (Type ~ Bool) failed to unify. + +Now, consider the following example: + + type family Id a where Id x = x + type T :: Bool -> Type + type T (a :: Id Bool) = ... + +We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. +However, we are free to discard it, as the kind of 'T' is determined by the +signature, not by the inline kind annotation: + + we have T :: Bool -> Type + rather than T :: Id Bool -> Type + +This (Id Bool) will not show up anywhere after we're done validating it, so we +have no use for the produced coercion. +-} + +{- Note [No polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should this kind-check? + data T ka (a::ka) b = MkT (T Type Int Bool) + (T (Type -> Type) Maybe Bool) + +Notice that T is used at two different kinds in its RHS. No! +This should not kind-check. Polymorphic recursion is known to +be a tough nut. + +Previously, we laboriously (with help from the renamer) +tried to give T the polymorphic kind + T :: forall ka -> ka -> kappa -> Type +where kappa is a unification variable, even in the inferInitialKinds +phase (which is what kcInferDeclHeader is all about). But +that is dangerously fragile (see the ticket). + +Solution: make kcInferDeclHeader give T a straightforward +monomorphic kind, with no quantification whatsoever. That's why +we use mkAnonTyConBinder for all arguments when figuring out +tc_binders. + +But notice that (#16322 comment:3) + +* The algorithm successfully kind-checks this declaration: + data T2 ka (a::ka) = MkT2 (T2 Type a) + + Starting with (inferInitialKinds) + T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * + we get + kappa4 := kappa1 -- from the (a:ka) kind signature + kappa1 := Type -- From application T2 Type + + These constraints are soluble so generaliseTcTyCon gives + T2 :: forall (k::Type) -> k -> * + + But now the /typechecking/ (aka desugaring, tcTyClDecl) phase + fails, because the call (T2 Type a) in the RHS is ill-kinded. + + We'd really prefer all errors to show up in the kind checking + phase. + +* This algorithm still accepts (in all phases) + data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) + although T3 is really polymorphic-recursive too. + Perhaps we should somehow reject that. + +Note [Kind variable ordering for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should be the kind of `T` in the following example? (#15591) + + class C (a :: Type) where + type T (x :: f a) + +As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify +the kind variables in left-to-right order of first occurrence in order to +support visible kind application. But we cannot perform this analysis on just +T alone, since its variable `a` actually occurs /before/ `f` if you consider +the fact that `a` was previously bound by the parent class `C`. That is to say, +the kind of `T` should end up being: + + T :: forall a f. f a -> Type + +(It wouldn't necessarily be /wrong/ if the kind ended up being, say, +forall f a. f a -> Type, but that would not be as predictable for users of +visible kind application.) + +In contrast, if `T` were redefined to be a top-level type family, like `T2` +below: + + type family T2 (x :: f (a :: Type)) + +Then `a` first appears /after/ `f`, so the kind of `T2` should be: + + T2 :: forall f a. f a -> Type + +In order to make this distinction, we need to know (in kcCheckDeclHeader) which +type variables have been bound by the parent class (if there is one). With +the class-bound variables in hand, we can ensure that we always quantify +these first. +-} + + +{- ********************************************************************* +* * + Expected kinds +* * +********************************************************************* -} + +-- | Describes the kind expected in a certain context. +data ContextKind = TheKind TcKind -- ^ a specific kind + | AnyKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + +----------------------- +newExpectedKind :: ContextKind -> TcM TcKind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind + +----------------------- +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt (TySynCtxt _) = AnyKind +expectedKindInCtxt (GhciCtxt {}) = AnyKind +-- The types in a 'default' decl can have varying kinds +-- See Note [Extended defaults]" in GHC.Tc.Utils.Env +expectedKindInCtxt DefaultDeclCtxt = AnyKind +expectedKindInCtxt DerivClauseCtxt = AnyKind +expectedKindInCtxt TypeAppCtxt = AnyKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind + + +{- ********************************************************************* +* * + Scoped tyvars that map to the same thing +* * +********************************************************************* -} + +checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () +-- Check for duplicates +-- E.g. data SameKind (a::k) (b::k) +-- data T (a::k1) (b::k2) c = MkT (SameKind a b) c +-- Here k1 and k2 start as TyVarTvs, and get unified with each other +-- If this happens, things get very confused later, so fail fast +-- +-- In the CUSK case k1 and k2 are skolems so they won't unify; +-- but in the inference case (see generaliseTcTyCon), +-- and the type-sig case (see kcCheckDeclHeader_sig), they are +-- TcTyVars, so we must check. +checkForDuplicateScopedTyVars scoped_prs + = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + where + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs + , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) 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 $ TcRnUnknownMessage $ mkPlainError noHints $ + 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) ] + + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + +-------------------------------------- +-- HsForAllTelescope +-------------------------------------- + +tcTKTelescope :: TcTyMode + -> HsForAllTelescope GhcRn + -> TcM a + -> TcM ([TcTyVarBinder], a) +-- A HsForAllTelescope comes only from a HsForAllTy, +-- an explicit, user-written forall type +tcTKTelescope mode tele thing_inside = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- req_tv_bndrs :: [VarBndr TyVar ()], + -- but we want [VarBndr TyVar ArgFlag] + ; return (tyVarReqToBinders req_tv_bndrs, thing) } + + HsForAllInvis { hsf_invis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- inv_tv_bndrs :: [VarBndr TyVar Specificity], + -- but we want [VarBndr TyVar ArgFlag] + ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } + +-------------------------------------- +-- HsOuterTyVarBndrs +-------------------------------------- + +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed + => SkolemMode + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a + -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +bindOuterTKBndrsX skol_mode outer_bndrs thing_inside + = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside + ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} + , thing) } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' + , hso_bndrs = exp_bndrs } + , thing) } + +--------------- +outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] +-- The returned [TcTyVar] is not necessarily in dependency order +-- at least for the HsOuterImplicit case +outerTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs +outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs + +--------------- +outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder] +outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs] +outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs + +--------------- +scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc) +-- Sort any /implicit/ binders into dependency order +-- (zonking first so we can see the dependencies) +-- /Explicit/ ones are already in the right order +scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) + = do { imp_tvs <- zonkAndScopedSort imp_tvs + ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) } +scopedSortOuter bndrs@(HsOuterExplicit{}) + = -- No need to dependency-sort (or zonk) explicit quantifiers + return bndrs + +--------------- +bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn + -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) +bindOuterSigTKBndrs_Tv + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) + +bindOuterSigTKBndrs_Tv_M :: TcTyMode + -> HsOuterSigTyVarBndrs GhcRn + -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) +-- Do not push level; do not make implication constraint; use Tvs +-- Two major clients of this "bind-only" path are: +-- Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl +-- Note [Checking partial type signatures] +bindOuterSigTKBndrs_Tv_M mode + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv + , sm_holes = mode_holes mode }) + +bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn + -> TcM a + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) +bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDTyVarTv }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindOuterFamEqnTKBndrs :: SkolemInfo + -> HsOuterFamEqnTyVarBndrs GhcRn + -> TcM a + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) +bindOuterFamEqnTKBndrs skol_info + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDSkolemTv skol_info }) + -- sm_clone=False: see Note [Cloning for type variable binders] + +--------------- +tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed + => SkolemInfo + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +tcOuterTKBndrs skol_info + = tcOuterTKBndrsX (smVanilla { sm_clone = False + , sm_tvtv = SMDSkolemTv skol_info }) + skol_info + -- Do not clone the outer binders + -- See Note [Cloning for type variable binder] under "must not" + +tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed + => SkolemMode -> SkolemInfo + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +-- Push level, capture constraints, make implication +tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside + = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside + ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} + , thing) } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' + , hso_bndrs = exp_bndrs } + , thing) } + +-------------------------------------- +-- Explicit tyvar binders +-------------------------------------- + +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +tcExplicitTKBndrs skol_info + = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) + +tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed + => SkolemMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +-- Push level, capture constraints, and emit an implication constraint. +-- The implication constraint has a ForAllSkol ic_info, +-- so that it is subject to a telescope test. +tcExplicitTKBndrsX skol_mode bndrs thing_inside + | null bndrs + = do { res <- thing_inside + ; return ([], res) } + + | otherwise + = do { (tclvl, wanted, (skol_tvs, res)) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKBndrsX skol_mode bndrs $ + thing_inside + + -- Set up SkolemInfo for telescope test + ; let bndr_1 = head bndrs; bndr_n = last bndrs + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + -- Notice that we use ForAllSkol here, ignoring the enclosing + -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope + -- test applies only to ForAllSkol + + ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n)) + $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted + + ; return (skol_tvs, res) } + +---------------- +-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied +-- 'TcTyMode'. +bindExplicitTKBndrs_Skol + :: (OutputableBndrFlag flag 'Renamed) + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Tv + :: (OutputableBndrFlag flag 'Renamed) + => [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info }) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) + -- sm_clone: see Note [Cloning for type variable binders] + +bindExplicitTKBndrs_Q_Skol + :: SkolemInfo + -> ContextKind + -> [LHsTyVarBndr () GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) + +bindExplicitTKBndrs_Q_Tv + :: ContextKind + -> [LHsTyVarBndr () GhcRn] + -> TcM a + -> TcM ([TcTyVar], a) +-- These do not clone: see Note [Cloning for type variable binders] +bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside + = liftFstM binderVars $ + bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside + = liftFstM binderVars $ + bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed) + => SkolemMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind + , sm_holes = hole_info }) + hs_tvs thing_inside + = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs) + ; go hs_tvs } + where + tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info } + -- Inherit the HoleInfo from the context + + go [] = do { res <- thing_inside + ; return ([], res) } + go (L _ hs_tv : hs_tvs) + = do { lcl_env <- getLclTypeEnv + ; tv <- tc_hs_bndr lcl_env hs_tv + -- Extend the environment as we go, in case a binder + -- is mentioned in the kind of a later binder + -- e.g. forall k (a::k). blah + -- NB: tv's Name may differ from hs_tv's + -- See Note [Cloning for type variable binders] + ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ + go hs_tvs + ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } + + + tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name)) + | check_parent + , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name + = return tv + | otherwise + = do { kind <- newExpectedKind ctxt_kind + ; newTyVarBndr skol_mode name kind } + + tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind) + | check_parent + , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name + = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind + ; discardResult $ + unifyKind (Just . NameThing $ name) kind (tyVarKind tv) + -- This unify rejects: + -- class C (m :: * -> *) where + -- type F (m :: *) = ... + ; return tv } + + | otherwise + = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind + ; newTyVarBndr skol_mode name kind } + +newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar +newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind + = do { name <- case clone of + True -> do { uniq <- newUnique + ; return (setNameUnique name uniq) } + False -> return name + ; details <- case tvtv of + SMDTyVarTv -> newMetaDetails TyVarTv + SMDSkolemTv skol_info -> + do { lvl <- getTcLevel + ; return (SkolemTv skol_info lvl False) } + ; return (mkTcTyVar name kind details) } + +-------------------------------------- +-- Implicit tyvar binders +-------------------------------------- + +tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo + -> [Name] + -> TcM a + -> TcM ([TcTyVar], a) +-- The workhorse: +-- push level, capture constraints, and emit an implication constraint +tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside + | null bndrs -- Short-cut the common case with no quantifiers + -- E.g. f :: Int -> Int + -- makes a HsOuterImplicit with empty bndrs, + -- and tcOuterTKBndrsX goes via here + = do { res <- thing_inside; return ([], res) } + | otherwise + = do { (tclvl, wanted, (skol_tvs, res)) + <- pushLevelAndCaptureConstraints $ + bindImplicitTKBndrsX skol_mode bndrs $ + thing_inside + + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + + ; return (skol_tvs, res) } + +------------------ +bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) + +bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a) +bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) +bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv }) + +bindImplicitTKBndrsX + :: SkolemMode + -> [Name] -- Generated by renamer; not in dependency order + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed in [Name] +bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind }) + tv_names thing_inside + = do { lcl_env <- getLclTypeEnv + ; tkvs <- mapM (new_tv lcl_env) tv_names + ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs) + ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) + thing_inside + ; return (tkvs, res) } + where + new_tv lcl_env name + | check_parent + , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name + = return tv + | otherwise + = do { kind <- newExpectedKind ctxt_kind + ; newTyVarBndr skol_mode name kind } + +-------------------------------------- +-- SkolemMode +-------------------------------------- + +-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or +-- implicit ('Name') binder in a type. It is just a record of flags +-- that describe what sort of 'TcTyVar' to create. +data SkolemMode + = SM { sm_parent :: Bool -- True <=> check the in-scope parent type variable + -- Used only for asssociated types + + , sm_clone :: Bool -- True <=> fresh unique + -- See Note [Cloning for type variable binders] + + , sm_tvtv :: SkolemModeDetails -- True <=> use a TyVarTv, rather than SkolemTv + -- Why? See Note [Inferring kinds for type declarations] + -- in GHC.Tc.TyCl, and (in this module) + -- Note [Checking partial type signatures] + + , sm_kind :: ContextKind -- Use this for the kind of any new binders + + , sm_holes :: HoleInfo -- What to do for wildcards in the kind + } + +data SkolemModeDetails + = SMDTyVarTv + | SMDSkolemTv SkolemInfo + + +smVanilla :: HasCallStack => SkolemMode +smVanilla = SM { sm_clone = panic "sm_clone" -- We always override this + , sm_parent = False + , sm_tvtv = pprPanic "sm_tvtv" callStackDoc -- We always override this + , sm_kind = AnyKind + , sm_holes = Nothing } + +{- Note [Cloning for type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we must clone the Name of a type variable binder (written in +the source program); and sometimes we must not. This is controlled by +the sm_clone field of SkolemMode. + +In some cases it doesn't matter whether or not we clone. Perhaps +it'd be better to use MustClone/MayClone/MustNotClone. + +When we /must not/ clone +* In the binders of a type signature (tcOuterTKBndrs) + f :: forall a{27}. blah + f = rhs + Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType), + we must get the type (forall a{27}. blah) for the Id f, because + we bring that type variable into scope when we typecheck 'rhs'. + +* In the binders of a data family instance (bindOuterFamEqnTKBndrs) + data instance + forall p q. D (p,q) = D1 p | D2 q + We kind-check the LHS in tcDataFamInstHeader, and then separately + (in tcDataFamInstDecl) bring p,q into scope before looking at the + the constructor decls. + +* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone + We take advantage of this in kcInferDeclHeader: + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + If we cloned, we'd need to take a bit more care here; not hard. + +* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone. + There is no need, I think. + + The payoff here is that avoiding gratuitous cloning means that we can + almost always take the fast path in swizzleTcTyConBndrs. + +When we /must/ clone. +* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning + + This for a narrow and tricky reason which, alas, I couldn't find a + simpler way round. #16221 is the poster child: + + data SameKind :: k -> k -> * + data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int + + When kind-checking T, we give (a :: kappa1). Then: + + - In kcConDecl we make a TyVarTv unification variable kappa2 for k2 + (as described in Note [Using TyVarTvs for kind-checking GADTs], + even though this example is an existential) + - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv + - We end up unifying kappa1 := kappa2, because of the (SameKind a b) + + Now we generalise over kappa2. But if kappa2's Name is precisely k2 + (i.e. we did not clone) we'll end up giving T the utterly final kind + T :: forall k2. k2 -> * + Nothing directly wrong with that but when we typecheck the data constructor + we have k2 in scope; but then it's brought into scope /again/ when we find + the forall k2. This is chaotic, and we end up giving it the type + MkT :: forall k2 (a :: k2) k2 (b :: k2). + SameKind @k2 a b -> Int -> T @{k2} a + which is bogus -- because of the shadowing of k2, we can't + apply T to the kind or a! + + And there no reason /not/ to clone the Name when making a unification + variable. So that's what we do. +-} + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a +-- ^ Bring into scope the binders of a PolyTcTyCon +-- Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- tcLookupTcTyCon tycon_name -- The tycon is a PolyTcTyCon + ; let res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders) + ; tcExtendTyVarEnv (binderVars binders) $ + thing_inside binders res_kind } + +bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a +-- Like bindTyClTyVars, but in addition +-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars +bindTyClTyVarsAndZonk tycon_name thing_inside + = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> + do { ze <- mkEmptyZonkEnv NoFlexi + ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; kind <- zonkTcTypeToTypeX ze tc_kind + ; thing_inside bndrs kind } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs + -- Zonk the kinds, to we can do the dependency analayis + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in GHC.Rename.HsType + ; return (scopedSort spec_tkvs) } + +-- | Generalize some of the free variables in the given type. +-- All such variables should be *kind* variables; any type variables +-- should be explicitly quantified (with a `forall`) before now. +-- +-- The WantedConstraints are un-solved kind constraints. Generally +-- they'll be reported as errors later, but meanwhile we refrain +-- from quantifying over any variable free in these unsolved +-- constraints. See Note [Failure in local type signatures]. +-- +-- But in all cases, generalize only those variables whose TcLevel is +-- strictly greater than the ambient level. This "strictly greater +-- than" means that you likely need to push the level before creating +-- whatever type gets passed here. +-- +-- Any variable whose level is greater than the ambient level but is +-- not selected to be generalized will be promoted. (See [Promoting +-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for +-- checking a signature].) +-- +-- The resulting KindVar are the variables to quantify over, in the +-- correct, well-scoped order. They should generally be Inferred, not +-- Specified, but that's really up to the caller of this function. +kindGeneralizeSome :: SkolemInfo + -> WantedConstraints + -> TcType -- ^ needn't be zonked + -> TcM [KindVar] +kindGeneralizeSome skol_info wanted kind_or_type + = do { -- Use the "Kind" variant here, as any types we see + -- here will already have all type variables quantified; + -- thus, every free variable is really a kv, never a tv. + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; dvs <- filterConstrainedCandidates wanted dvs + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } + +filterConstrainedCandidates + :: WantedConstraints -- Don't quantify over variables free in these + -- Not necessarily fully zonked + -> CandidatesQTvs -- Candidates for quantification + -> TcM CandidatesQTvs +-- filterConstrainedCandidates removes any candidates that are free in +-- 'wanted'; instead, it promotes them. This bit is very much like +-- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much +-- simpler in kinds, it is much easier here. (In particular, we never +-- quantify over a constraint in a type.) +filterConstrainedCandidates wanted dvs + | isEmptyWC wanted -- Fast path for a common case + = return dvs + | otherwise + = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) + ; _ <- promoteTyVarSet to_promote + ; return dvs' } + +-- |- Specialised version of 'kindGeneralizeSome', but with empty +-- WantedConstraints, so no filtering is needed +-- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC +kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar] +kindGeneralizeAll skol_info kind_or_type + = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } + +-- | Specialized version of 'kindGeneralizeSome', but where no variables +-- can be generalized, but perhaps some may need to be promoted. +-- Use this variant when it is unknowable whether metavariables might +-- later be constrained. +-- +-- To see why this promotion is needed, see +-- Note [Recipe for checking a signature], and especially +-- Note [Promotion in signatures]. +kindGeneralizeNone :: TcType -- needn't be zonked + -> TcM () +kindGeneralizeNone kind_or_type + = do { traceTc "kindGeneralizeNone" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; _ <- promoteTyVarSet (candidateKindVars dvs) + ; return () } + +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residiual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. + +-} + +----------------------------------- +etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +etaExpandAlgTyCon flav skol_info tcbs res_kind + | needsEtaExpansion flav + = splitTyConKind skol_info in_scope avoid_occs res_kind + | otherwise + = return ([], res_kind) + where + tyvars = binderVars tcbs + in_scope = mkInScopeSet (mkVarSet tyvars) + avoid_occs = map getOccName tyvars + +needsEtaExpansion :: TyConFlavour -> Bool +needsEtaExpansion NewtypeFlavour = True +needsEtaExpansion DataTypeFlavour = True +needsEtaExpansion ClassFlavour = True +needsEtaExpansion _ = False + +splitTyConKind :: SkolemInfo + -> InScopeSet + -> [OccName] -- Avoid these OccNames + -> Kind -- Must be zonked + -> TcM ([TcTyConBinder], TcKind) +-- GADT decls can have a (perhaps partial) kind signature +-- e.g. data T a :: * -> * -> * where ... +-- This function makes up suitable (kinded) TyConBinders for the +-- argument kinds. E.g. in this case it might return +-- ([b::*, c::*], *) +-- Skolemises the type as it goes, returning skolem TcTyVars +-- Never emits constraints. +-- It's a little trickier than you might think: see Note [splitTyConKind] +-- See also Note [Datatype return kinds] in GHC.Tc.TyCl +splitTyConKind skol_info in_scope avoid_occs kind + = do { loc <- getSrcSpanM + ; uniqs <- newUniqueSupply + ; rdr_env <- getLocalRdrEnv + ; lvl <- getTcLevel + ; let new_occs = [ occ + | str <- allNameStrings + , let occ = mkOccName tvName str + , isNothing (lookupLocalRdrOcc rdr_env occ) + -- Note [Avoid name clashes for associated data types] + , not (occ `elem` avoid_occs) ] + new_uniqs = uniqsFromSupply uniqs + subst = mkEmptyTCvSubst in_scope + details = SkolemTv skol_info (pushTcLevel lvl) False + -- As always, allocate skolems one level in + + go occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon af arg, kind') + -> go occs' uniqs' subst' (tcb : acc) kind' + where + tcb = Bndr tv (AnonTCB af) + arg' = substTy subst (scaledThing arg) + name = mkInternalName uniq occ loc + tv = mkTcTyVar name arg' details + subst' = extendTCvInScope subst tv + (uniq:uniqs') = uniqs + (occ:occs') = occs + + Just (Named (Bndr tv vis), kind') + -> go occs uniqs subst' (tcb : acc) kind' + where + tcb = Bndr tv' (NamedTCB vis) + tc_tyvar = mkTcTyVar (tyVarName tv) (tyVarKind tv) details + (subst', tv') = substTyVarBndr subst tc_tyvar + + ; return (go new_occs new_uniqs subst [] kind) } + +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +-- | Local helper type used in 'checkDataKindSig'. +-- +-- Superficially similar to 'ContextKind', but it lacks 'AnyKind' +-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ +-- provides 'LiftedKind', which is much simpler to match on and +-- handle in 'isAllowedDataResKind'. +data AllowedDataResKind + = AnyTYPEKind + | AnyBoxedKind + | LiftedKind + +isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool +isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind +isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +-- +-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" +checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off + -> TcM () +checkDataKindSig data_sort kind + = do { dflags <- getDynFlags + ; traceTc "checkDataKindSig" (ppr kind) + ; checkTc (tYPE_ok dflags || is_kind_var) + (err_msg dflags) } + where + res_kind = snd (tcSplitPiTys kind) + -- Look for the result kind after + -- peeling off any foralls and arrows + + pp_dec :: SDoc + pp_dec = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_datatype :: Bool + is_datatype = + case data_sort of + DataDeclSort DataType -> True + DataInstanceSort DataType -> True + _ -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + allowed_kind :: DynFlags -> AllowedDataResKind + allowed_kind dflags + | is_newtype && xopt LangExt.UnliftedNewtypes dflags + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + = AnyTYPEKind + | is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + = AnyTYPEKind + | is_datatype && xopt LangExt.UnliftedDatatypes dflags + -- With UnliftedDatatypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE (BoxedRep l)`, so that we don't + -- accept result kinds like `TYPE IntRep`. + -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. + = AnyBoxedKind + | otherwise + = LiftedKind + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind) + | otherwise = False + + pp_allowed_kind dflags = + case allowed_kind dflags of + AnyTYPEKind -> ppr tYPETyCon + AnyBoxedKind -> ppr boxedRepDataConTyCon + LiftedKind -> ppr liftedTypeKind + + err_msg :: DynFlags -> TcRnMessage + err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $ + sep [ sep [ pp_dec <+> + text "has non-" <> + pp_allowed_kind dflags + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) ] + , ext_hint dflags ] + + ext_hint dflags + | tcIsRuntimeTypeKind kind + , is_newtype + , not (xopt LangExt.UnliftedNewtypes dflags) + = text "Perhaps you intended to use UnliftedNewtypes" + | tcIsBoxedTypeKind kind + , is_datatype + , not (xopt LangExt.UnliftedDatatypes dflags) + = text "Perhaps you intended to use UnliftedDatatypes" + | otherwise + = empty + +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting +-- type synonyms and type families that reduce to `Constraint`. See #16826. +checkClassKindSig :: Kind -> TcM () +checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg + where + err_msg :: TcRnMessage + err_msg = TcRnUnknownMessage $ mkPlainError noHints $ + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correspondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + go fun_kind subst all_args@(arg : args) + | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind + = case tcb of + Anon af _ -> AnonTCB af : go inner_kind subst args + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + +{- Note [splitTyConKind] +~~~~~~~~~~~~~~~~~~~~~~~~ +Given + data T (a::*) :: * -> forall k. k -> * +we want to generate the extra TyConBinders for T, so we finally get + (a::*) (b::*) (k::*) (c::k) +The function splitTyConKind generates these extra TyConBinders from +the result kind signature. The same function is also used by +kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of +the TyCon given in a standalone kind signature. E.g. + type T :: forall (a::*). * -> forall k. k -> * + +We need to take care to give the TyConBinders + (a) Uniques that are fresh: the TyConBinders of a TyCon + must have distinct uniques. + + (b) Preferably, OccNames that are fresh. If we happen to re-use + OccNames that are other TyConBinders, we'll get a TyCon with + TyConBinders like [a_72, a_53]; same OccName, different Uniques. + Then when pretty-printing (e.g. in GHCi :info) we'll see + data T a a0 + whereas we'd prefer + data T a b + (NB: the tidying happens in the conversion to Iface syntax, + which happens as part of pretty-printing a TyThing.) + + Using fresh OccNames is not essential; it's cosmetic. + And also see Note [Avoid name clashes for associated data types]. + +For (a) perhaps surprisingly, duplicated uniques can happen, even if +we use fresh uniques for Anon arrows. Consider + data T :: forall k. k -> forall k. k -> * +where the two k's are identical even up to their uniques. Surprisingly, +this can happen: see #14515, #19092,3,4. Then if we use those k's in +as TyConBinders we'll get duplicated uniques. + +For (b) we'd like to avoid OccName clashes with the tyvars declared by +the user before the "::"; in the above example that is 'a'. + +It's reasonably easy to solve all this; just run down the list with a +substitution; hence the recursive 'go' function. But for the Uniques +it has to be done. + +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get + class C a b where + data D b a0 +(NB: the tidying happens in the conversion to Iface syntax, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. + + +************************************************************************ +* * + Partial signatures +* * +************************************************************************ + +-} + +tcHsPartialSigType + :: UserTypeCtxt + -> LHsSigWcType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , Maybe TcType -- Extra-constraints wildcard + , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with + -- the implicitly and explicitly bound type variables + , TcThetaType -- Theta part + , TcType ) -- Tau part +-- See Note [Checking partial type signatures] +tcHsPartialSigType ctxt sig_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty + , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty + , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty + = addSigCtxt ctxt sig_ty $ + do { mode <- mkHoleMode TypeLevel HM_Sig + ; (outer_bndrs, (wcs, wcx, theta, tau)) + <- solveEqualities "tcHsPartialSigType" $ + -- See Note [Failure in local type signatures] + bindNamedWildCardBinders sig_wcs $ \ wcs -> + bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $ + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + (theta, wcx) <- tcPartialContext mode hs_ctxt + + ; ek <- newOpenTypeKind + ; tau <- addTypeCtxt hs_tau $ + tc_lhs_type mode hs_tau ek + + ; return (wcs, wcx, theta, tau) } + + ; traceTc "tcHsPartialSigType 2" empty + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs + ; traceTc "tcHsPartialSigType 3" empty + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ + mkPhiTy theta $ + tau) + + -- Spit out the wildcards (including the extra-constraints one) + -- as "hole" constraints, so that they'll be reported if necessary + -- See Note [Extra-constraint holes in partial type signatures] + ; mapM_ emitNamedTypeHole wcs + + -- Zonk, so that any nested foralls can "see" their occurrences + -- See Note [Checking partial type signatures], and in particular + -- Note [Levels for wildcards] + ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs + ; theta <- mapM zonkTcType theta + ; tau <- zonkTcType tau + + -- We return a proper (Name,InvisTVBinder) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let outer_bndr_names :: [Name] + outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs + tv_prs :: [(Name,InvisTVBinder)] + tv_prs = outer_bndr_names `zip` outer_tv_bndrs + + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete type to check + + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } + +tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) +tcPartialContext _ Nothing = return ([], Nothing) +tcPartialContext mode (Just (L _ hs_theta)) + | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta + , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- setSrcSpanA wc_loc $ + tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind + ; theta <- mapM (tc_lhs_pred mode) hs_theta1 + ; return (theta, Just wc_tv_ty) } + | otherwise + = do { theta <- mapM (tc_lhs_pred mode) hs_theta + ; return (theta, Nothing) } + +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is about tcHsPartialSigType. See also +Note [Recipe for checking a signature] + +When we have a partial signature like + f :: forall a. a -> _ +we do the following + +* tcHsPartialSigType does not make quantified type (forall a. blah) + and then instantiate it -- it makes no sense to instantiate a type + with wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ + a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider + f :: forall a. a -> _ + g :: forall b. _ -> b + f = g + g = f + They are typechecked as a recursive group, with monomorphic types, + so 'a' and 'b' will get unified together. Very like kind inference + for mutually recursive data types (sans CUSKs or SAKS); see + Note [Cloning for type variable binders] + +* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tchsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + because they might get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Nested foralls. See Note [Levels for wildcards] + +* Just as for ordinary signatures, we must solve local equalities and + zonk the type after kind-checking it, to ensure that all the nested + forall binders can "see" their occurrenceds + + Just as for ordinary signatures, this zonk also gets any Refl casts + out of the way of instantiation. Example: #18008 had + foo :: (forall a. (Show a => blah) |> Refl) -> _ + and that Refl cast messed things up. See #18062. + +Note [Levels for wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b. (forall a. a -> _) -> b +We do /not/ allow the "_" to be instantiated to 'a'; although we do +(as before) allow it to be instantiated to the (top level) 'b'. +Why not? Suppose + f x = (x True, x 'c') + +During typecking the RHS we must instantiate that (forall a. a -> _), +so we must know /precisely/ where all the a's are; they must not be +hidden under (possibly-not-yet-filled-in) unification variables! + +We achieve this as follows: + +- For /named/ wildcards such sas + g :: forall b. (forall la. a -> _x) -> b + there is no problem: we create them at the outer level (ie the + ambient level of the signature itself), and push the level when we + go inside a forall. So now the unification variable for the "_x" + can't unify with skolem 'a'. + +- For /anonymous/ wildcards, such as 'f' above, we carry the ambient + level of the signature to the hole in the TcLevel part of the + mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that + level (and /not/ the level ambient at the occurrence of "_") to + create the unification variable for the wildcard. That is the sole + purpose of the TcLevel in the mode_holes field: to transport the + ambient level of the signature down to the anonymous wildcard + occurrences. + +Note [Extra-constraint holes in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (_) => a -> a + f x = ... + +* The renamer leaves '_' untouched. + +* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in + tcWildCardBinders. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.mkHoleError finally reports the error. + +An annoying difficulty happens if there are more than 64 inferred +constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. +Where do we find the TyCon? For good reasons we only have constraint +tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how +can we make a 70-tuple? This was the root cause of #14217. + +It's incredibly tiresome, because we only need this type to fill +in the hole, to communicate to the error reporting machinery. Nothing +more. So I use a HACK: + +* I make an /ordinary/ tuple of the constraints, in + GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because + ordinary tuples can't contain constraints, but it works fine. And for + ordinary tuples we don't have the same limit as for constraint + tuples (which need selectors and an associated class). + +* Because it is ill-kinded (unifying something of kind Constraint with + something of kind Type), it should trip an assert in writeMetaTyVarRef. + However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling + over in this scenario (and another scenario, as detailed in + Note [coreView vs tcView] in GHC.Core.Type). + +Result works fine, but it may eventually bite us. + +See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for +information about how these are printed. + +************************************************************************ +* * + Pattern signatures (i.e signatures that occur in patterns) +* * +********************************************************************* -} + +tcHsPatSigType :: UserTypeCtxt + -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. + -> HsPatSigType GhcRn -- The type signature + -> ContextKind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcHsPatSigType ctxt hole_mode + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + ctxt_kind + = addSigCtxt ctxt hs_ty $ + do { sig_tkv_prs <- mapM new_implicit_tv sig_ns + ; mode <- mkHoleMode TypeLevel hole_mode + ; (wcs, sig_ty) + <- addTypeCtxt hs_ty $ + solveEqualities "tcHsPatSigType" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + bindNamedWildCardBinders sig_wcs $ \ wcs -> + tcExtendNameTyVarEnv sig_tkv_prs $ + do { ek <- newExpectedKind ctxt_kind + ; sig_ty <- tc_lhs_type mode hs_ty ek + ; return (wcs, sig_ty) } + + ; mapM_ emitNamedTypeHole wcs + + -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty + -- contains a forall). Promote these. + -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... + -- When we instantiate x, we have to compare the kind of the argument + -- to a's kind, which will be a metavariable. + -- kindGeneralizeNone does this: + ; kindGeneralizeNone sig_ty + ; sig_ty <- zonkTcType sig_ty + ; checkValidType ctxt sig_ty + + ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) + ; return (wcs, sig_tkv_prs, sig_ty) } + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; tv <- case ctxt of + RuleSigCtxt rname _ -> do + skol_info <- mkSkolemInfo (RuleSkol rname) + newSkolemTyVar skol_info name kind + _ -> newPatSigTyVar name kind + -- See Note [Typechecking pattern signature binders] + -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) + ; return (name, tv) } + +{- Note [Typechecking pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Type variables in the type environment] in GHC.Tc.Utils. +Consider + + data T where + MkT :: forall a. a -> (a -> Int) -> T + + f :: T -> ... + f (MkT x (f :: b -> c)) = + +Here + * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that it retains its identity, and + GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. + + * The type signature pattern (f :: b -> c) makes fresh meta-tyvars + beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the + environment + + * Then unification makes beta := a_sk, gamma := Int + That's why we must make beta and gamma a MetaTv, + not a SkolemTv, so that it can unify to a_sk (or Int, respectively). + + * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, + so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, + +Another example (#13881): + fl :: forall (l :: [a]). Sing l -> Sing l + fl (SNil :: Sing (l :: [y])) = SNil +When we reach the pattern signature, 'l' is in scope from the +outer 'forall': + "a" :-> a_sk :: * + "l" :-> l_sk :: [a_sk] +We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check +the pattern signature + Sing (l :: [y]) +That unifies y_sig := a_sk. We return from tcHsPatSigType with +the pair ("y" :-> y_sig). + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. Hence the new_implicit_tv function in tcHsPatSigType. + + +************************************************************************ +* * + Checking kinds +* * +************************************************************************ + +-} + +unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) +unifyKinds rn_tys act_kinds + = do { kind <- newMetaKindVar + ; let check rn_ty (ty, act_kind) + = checkExpectedKind (unLoc rn_ty) ty act_kind kind + ; tys' <- zipWithM check rn_tys act_kinds + ; return (tys', kind) } + +{- +************************************************************************ +* * + Sort checking kinds +* * +************************************************************************ + +tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +-} + +tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tcLHsKindSig ctxt hs_kind + = tc_lhs_kind_sig kindLevelMode ctxt hs_kind + +tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tc_lhs_kind_sig mode ctxt hs_kind +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +-- Result is zonked + = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $ + solveEqualities "tcLHsKindSig" $ + tc_lhs_type mode hs_kind liftedTypeKind + ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) + -- No generalization: + ; kindGeneralizeNone kind + ; kind <- zonkTcType kind + -- This zonk is very important in the case of higher rank kinds + -- E.g. #13879 f :: forall (p :: forall z (y::z). ). + -- + -- When instantiating p's kind at occurrences of p in + -- it's crucial that the kind we instantiate is fully zonked, + -- else we may fail to substitute properly + + ; checkValidType ctxt kind + ; traceTc "tcLHsKindSig2" (ppr kind) + ; return kind } + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE pred + -> text "it has an unpromotable context" + <+> quotes (ppr pred) + FamDataConPE -> text "it comes from a data family instance" NoDataKindsDC -> text "perhaps you intended to use DataKinds" PatSynPE -> text "pattern synonyms cannot be promoted" RecDataConPE -> same_rec_group_msg diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -433,7 +433,7 @@ -- Expression must be a function ; let herald = text "A view pattern expression expects" ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) - <- matchActualFunTySigma herald (Just (ppr expr)) (1,[]) expr_ty + <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty -- See Note [View patterns and polymorphism] -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) @@ -912,7 +912,11 @@ -- We want to create a well-kinded substitution, so -- that the instantiated type is well-kinded - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv1 ex_tvs + ; let mc = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc) + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs -- Get location from monad, not from ex_tvs -- This freshens: See Note [Freshen existentials] -- Why "super"? See Note [Binding when lookup up instances] @@ -953,16 +957,12 @@ { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' - skol_info = PatSkol (RealDataCon data_con) mc - mc = case pe_ctxt penv of - LamPat mc -> mc - LetPat {} -> PatBindRhs ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' given $ + <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $ tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside ; let res_pat = ConPat @@ -993,7 +993,11 @@ ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv - ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs + ; skol_info <- case pe_ctxt penv of + LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc) + LetPat {} -> return unkSkol -- Doesn't matter + + ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs -- This freshens: Note [Freshen existentials] ; let ty' = substTy tenv ty @@ -1019,9 +1023,6 @@ ; prov_dicts' <- newEvVars prov_theta' - ; let skol_info = case pe_ctxt penv of - LamPat mc -> PatSkol (PatSynCon pat_syn) mc - LetPat {} -> UnkSkol -- Doesn't matter ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta' -- Origin (OccurrenceOf con_name): @@ -1030,7 +1031,7 @@ ; traceTc "checkConstraints {" Outputable.empty ; (ev_binds, (arg_pats', res)) - <- checkConstraints skol_info ex_tvs' prov_dicts' $ + <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -28,7 +28,7 @@ import GHC.Core.Type import GHC.Core.TyCon( isTypeFamilyTyCon ) import GHC.Types.Id -import GHC.Types.Var( EvVar ) +import GHC.Types.Var( EvVar, tyVarName ) import GHC.Types.Var.Set import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) import GHC.Types.SrcLoc @@ -119,10 +119,10 @@ , rd_rhs = rhs }) = addErrCtxt (ruleCtxt name) $ do { traceTc "---- Rule ------" (pprFullRuleName rname) - + ; skol_info <- mkSkolemInfo (RuleSkol name) -- Note [Typechecking rules] ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints ty_bndrs tm_bndrs lhs rhs + generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs ; let (id_bndrs, lhs', lhs_wanted , rhs', rhs_wanted, rule_ty) = stuff @@ -134,7 +134,7 @@ ; (lhs_evs, residual_lhs_wanted) <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - -- SimplfyRule Plan, step 4 + -- SimplifyRule Plan, step 4 -- Now figure out what to quantify over -- c.f. GHC.Tc.Solver.simplifyInfer -- We quantify over any tyvars free in *either* the rule @@ -151,11 +151,13 @@ -- See Note [Re-quantify type variables in rules] ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars forall_tkvs + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars forall_tkvs ; traceTc "tcRule" (vcat [ pprFullRuleName rname , ppr forall_tkvs , ppr qtkvs , ppr rule_ty + , ppr ty_bndrs + , ppr (qtkvs ++ tpl_ids) , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] ]) @@ -164,12 +166,10 @@ -- For the LHS constraints we must solve the remaining constraints -- (a) so that we report insoluble ones -- (b) so that we bind any soluble ones - ; let skol_info = RuleSkol name - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info qtkvs + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs lhs_evs rhs_wanted - ; emitImplications (lhs_implic `unionBags` rhs_implic) ; return $ HsRule { rd_ext = ext , rd_name = rname @@ -180,21 +180,21 @@ , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] +generateRuleConstraints :: FastString + -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcM ( [TcId] , LHsExpr GhcTc, WantedConstraints , LHsExpr GhcTc, WantedConstraints , TcType ) -generateRuleConstraints ty_bndrs tm_bndrs lhs rhs +generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs ty_bndrs tm_bndrs + tcRuleBndrs rule_name ty_bndrs tm_bndrs -- bndr_wanted constraints can include wildcard hole -- constraints, which we should not forget about. -- It may mention the skolem type variables bound by -- the RULE. c.f. #10072 - - ; tcExtendTyVarEnv tv_bndrs $ + ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $ tcExtendIdEnv id_bndrs $ do { -- See Note [Solve order for RULES] ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) @@ -204,38 +204,39 @@ ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } -- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] +tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> TcM ([TcTyVar], [Id]) -tcRuleBndrs (Just bndrs) xs - = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs +tcRuleBndrs rule_name (Just bndrs) xs + = do { skol_info <- mkSkolemInfo (RuleSkol rule_name) + ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $ + tcRuleTmBndrs rule_name xs ; let tys1 = binderVars tybndrs1 ; return (tys1 ++ tys2, tms) } -tcRuleBndrs Nothing xs - = tcRuleTmBndrs xs +tcRuleBndrs rule_name Nothing xs + = tcRuleTmBndrs rule_name xs -- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs [] = return ([],[]) -tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs) +tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) +tcRuleTmBndrs _ [] = return ([],[]) +tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs + ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs ; return (tyvars, mkLocalId name Many ty : tmvars) } -tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) +tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a -- If there's an explicit forall, the renamer would have already reported an -- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt name + = do { let ctxt = RuleSigCtxt rule_name name ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind ; let id = mkLocalId name Many id_ty -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType -- The type variables scope over subsequent bindings; yuk ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_bndrs + tcRuleTmBndrs rule_name rule_bndrs ; return (map snd tvs ++ tyvars, id : tmvars) } ruleCtxt :: FastString -> SDoc @@ -306,8 +307,9 @@ * Step 0: typecheck the LHS and RHS to get constraints from each -* Step 1: Simplify the LHS and RHS constraints all together in one bag - We do this to discover all unification equalities +* Step 1: Simplify the LHS and RHS constraints all together in one bag, + but /discarding/ the simplified constraints. We do this only + to discover all unification equalities. * Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take advantage of those unifications diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -406,12 +406,12 @@ , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; let skol_info = DataConSkol name + ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $ -- See Note [solveEqualities in tcPatSynSig] - tcOuterTKBndrs skol_info hs_outer_bndrs $ - tcExplicitTKBndrs ex_hs_tvbndrs $ + tcOuterTKBndrs skol_info hs_outer_bndrs $ + tcExplicitTKBndrs skol_info ex_hs_tvbndrs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty @@ -432,7 +432,7 @@ ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - ; kvs <- kindGeneralizeAll ungen_patsyn_ty + ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty ; reportUnsolvedEqualities skol_info kvs tclvl wanted -- See Note [Report unsolved equalities in tcPatSynSig] @@ -590,7 +590,7 @@ -- add arity only for real INLINE pragmas, not INLINABLE = case lookupNameEnv ar_env n of Just ar -> inl_prag { inl_sat = Just ar } - Nothing -> warnPprTrace True (text "mkPragEnv no arity" <+> ppr n) $ + Nothing -> warnPprTrace True "mkPragEnv no arity" (ppr n) $ -- There really should be a binding for every INLINE pragma inl_prag | otherwise diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -618,7 +618,6 @@ {- Note [Collecting modFinalizers in typed splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local environment (see Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the @@ -679,12 +678,8 @@ -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) - = do - errs_var <- getErrsVar - setLclEnv lcl_env $ setErrsVar errs_var $ do { - -- Set the errs_var to the errs_var from the current context, - -- otherwise error messages can go missing in GHCi (#19470) - zonked_ty <- zonkTcType res_ty + = restoreLclEnv lcl_env $ + do { zonked_ty <- zonkTcType res_ty ; zonked_q_expr <- zonkTopLExpr q_expr -- See Note [Collecting modFinalizers in typed splices]. ; modfinalizers_ref <- newTcRef [] @@ -1697,16 +1692,16 @@ rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names -> do { (rn_ty, fvs) <- rnLHsType doc rdr_ty ; return ((tv_names, rn_ty), fvs) } - + ; skol_info <- mkSkolemInfo ReifySkol ; (tclvl, wanted, (tvs, ty)) <- pushLevelAndSolveEqualitiesX "reifyInstances" $ - bindImplicitTKBndrs_Skol tv_names $ + bindImplicitTKBndrs_Skol skol_info tv_names $ tcInferLHsType rn_ty ; tvs <- zonkAndScopedSort tvs -- Avoid error cascade if there are unsolved - ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted + ; reportUnsolvedEqualities skol_info tvs tclvl wanted ; ty <- zonkTcTypeToType ty -- Substitute out the meta type variables diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -79,7 +79,6 @@ import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign -import GHC.Tc.TyCl.Class ( ClassScopedTVEnv ) import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -465,7 +464,7 @@ -- * the local env exposes the local Ids to simplifyTop, -- so that we get better error messages (monomorphism restriction) ; new_ev_binds <- {-# SCC "simplifyTop" #-} - setEnvs (tcg_env, tcl_env) $ + restoreEnvs (tcg_env, tcl_env) $ do { lie_main <- checkMainType tcg_env ; simplifyTop (lie `andWC` lie_main) } @@ -474,6 +473,9 @@ mkTypeableBinds ; traceTc "Tc9" empty + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. @@ -506,19 +508,23 @@ --------- Deal with the exports ---------- -- Can't be done earlier, because the export list must "see" -- the declarations created by the finalizers - ; tcg_env <- setEnvs (tcg_env, tcl_env) $ + ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ rnExports explicit_mod_hdr export_ies --------- Emit the ':Main.main = runMainIO main' declaration ---------- -- Do this /after/ rnExports, so that it can consult -- the tcg_exports created by rnExports ; (tcg_env, main_ev_binds) - <- setEnvs (tcg_env, tcl_env) $ + <- restoreEnvs (tcg_env, tcl_env) $ do { (tcg_env, lie) <- captureTopConstraints $ checkMain explicit_mod_hdr export_ies ; ev_binds <- simplifyTop lie ; return (tcg_env, ev_binds) } + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + ---------- Final zonking --------------- -- Zonk the new bindings arising from running the finalisers, -- and main. This won't give rise to any more finalisers as you @@ -553,10 +559,7 @@ = {-# SCC "zonkTopDecls" #-} setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering -- error messages during zonking (notably levity errors) - do { failIfErrsM -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! - ; let all_ev_binds = cur_ev_binds `unionBags` ev_binds + do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds ; zonkTopDecls all_ev_binds binds rules imp_specs fords } -- | Runs TH finalizers and renames and typechecks the top-level declarations @@ -570,7 +573,7 @@ else do writeTcRef th_modfinalizers_var [] let run_finalizer (lcl_env, f) = - setLclEnv lcl_env (runRemoteModFinalizers f) + restoreLclEnv lcl_env (runRemoteModFinalizers f) (_, lie_th) <- captureTopConstraints $ mapM_ run_finalizer th_modfinalizers @@ -579,7 +582,7 @@ -- we have to run tc_rn_src_decls to get them (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] - setEnvs (tcg_env, tcl_env) $ do + restoreEnvs (tcg_env, tcl_env) $ do -- Subsequent rounds of finalizers run after any new constraints are -- simplified, or some types might not be complete when using reify -- (see #12777). @@ -646,7 +649,7 @@ tcTopSrcDecls rn_decls -- If there is no splice, we're nearly done - ; setEnvs (tcg_env, tcl_env) $ + ; restoreEnvs (tcg_env, tcl_env) $ case group_tail of { Nothing -> return (tcg_env, tcl_env, lie1) @@ -708,7 +711,7 @@ -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env, _th_bndrs) + ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { @@ -1467,7 +1470,7 @@ -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, class_scoped_tv_env, th_bndrs, + (tcg_env, inst_infos, th_bndrs, XValBindsLR (NValBinds deriv_binds deriv_sigs)) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; @@ -1498,20 +1501,19 @@ -- the bindings produced in a Data instance.) traceTc "Tc5" empty ; tc_envs <- tcTopBinds val_binds val_sigs; - setEnvs tc_envs $ do { + restoreEnvs tc_envs $ do { -- Now GHC-generated derived bindings, generics, and selectors -- Do not generate warnings from compiler-generated code; -- hence the use of discardWarnings tc_envs@(tcg_env, tcl_env) <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - setEnvs tc_envs $ do { -- Environment doesn't change now + restoreEnvs tc_envs $ do { -- Environment doesn't change now -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) - inst_infos class_scoped_tv_env ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1750,7 +1752,6 @@ [InstInfo GhcRn], -- Source-code instance decls to -- process; contains all dfuns for -- this module - ClassScopedTVEnv, -- Class scoped type variables ThBindEnv, -- TH binding levels HsValBinds GhcRn) -- Supporting bindings for derived -- instances @@ -1758,7 +1759,7 @@ tcTyClsInstDecls tycl_decls deriv_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $ - do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) + do { (tcg_env, inst_info, deriv_info, th_bndrs) <- tcTyAndClassDecls tycl_decls ; ; setGblEnv tcg_env $ do { -- With the @TyClDecl@s and @InstDecl@s checked we're ready to @@ -1772,8 +1773,7 @@ <- tcInstDeclsDeriv deriv_info deriv_decls ; setGblEnv tcg_env' $ do { failIfErrsM - ; pure ( tcg_env', inst_info' ++ inst_info - , class_scoped_tv_env, th_bndrs, val_binds ) + ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) }}} {- ********************************************************************* @@ -2058,34 +2058,31 @@ IIDecl i -> getOrphans (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) - ; let imports = emptyImportAvails { - imp_orphs = orphs - } + ; let imports = emptyImportAvails { imp_orphs = orphs } - ; (gbl_env, lcl_env) <- getEnvs - ; let gbl_env' = gbl_env { - tcg_rdr_env = icReaderEnv icxt - , tcg_type_env = type_env - , tcg_inst_env = extendInstEnvList - (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) - home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports - } + upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') + where + gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt + , tcg_type_env = type_env + , tcg_inst_env = extendInstEnvList + (extendInstEnvList (tcg_inst_env gbl_env) ic_insts) + home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_field_env = mkNameEnv con_fields + -- setting tcg_field_env is necessary + -- to make RecordWildCards work (test: ghci049) + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + -- must calculate imp_orphs of the ImportAvails + -- so that instance visibility is done correctly + , tcg_imports = imports } - lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids + lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids - ; setEnvs (gbl_env', lcl_env') thing_inside } + ; updEnvs upd_envs thing_inside } where (home_insts, home_fam_insts) = hptAllInstances hsc_env @@ -2653,7 +2650,7 @@ ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll kind + ; kvs <- kindGeneralizeAll unkSkol kind ; e <- mkEmptyZonkEnv flexi ; ty <- zonkTcTypeToTypeX e ty diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -66,7 +66,7 @@ import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM , unsafeTcPluginTcM , liftIO, traceTc ) -import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..), ctLocOrigin ) +import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) ) import GHC.Tc.Utils.TcMType ( TcTyVar, TcType ) import GHC.Tc.Utils.Env ( TcTyThing ) import GHC.Tc.Types.Evidence ( CoercionHole, EvTerm(..) @@ -162,10 +162,10 @@ zonkCt :: Ct -> TcPluginM Ct zonkCt = unsafeTcPluginTcM . TcM.zonkCt --- | Create a new wanted constraint. +-- | Create a new Wanted constraint with the given 'CtLoc'. newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence newWanted loc pty - = unsafeTcPluginTcM (TcM.newWanted (ctLocOrigin loc) Nothing pty) + = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty) -- | Create a new derived constraint. newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE RecursiveDo #-} module GHC.Tc.Solver( InferMode(..), simplifyInfer, findInferredDiff, @@ -58,6 +58,8 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type +import GHC.Core.Ppr +import GHC.Core.TyCon ( TyConBinder ) import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc @@ -163,17 +165,17 @@ ; return (evBindMapBinds binds1 `unionBags` binds2) } -pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a +pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a -- Push level, and solve all resulting equalities -- If there are any unsolved equalities, report them -- and fail (in the monad) -- -- Panics if we solve any non-equality constraints. (In runTCSEqualities -- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualities skol_info skol_tvs thing_inside +pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX "pushLevelAndSolveEqualities" thing_inside - ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted ; return res } pushLevelAndSolveEqualitiesX :: String -> TcM a @@ -227,11 +229,11 @@ -- Emit the bad constraints, wrapped in an implication -- See Note [Wrapping failing kind equalities] ; tclvl <- TcM.getTcLevel - ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted - -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ - -- it's OK to use UnkSkol | we must increase the TcLevel, - -- because we don't bind | as explained in - -- any skolem variables here | Note [Wrapping failing kind equalities] + ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use unkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] ; emitImplication implic ; failM } Just (simples, holes) @@ -460,13 +462,20 @@ -- -- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to -- provide skolem info for any errors. --- reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted + +report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted | isEmptyWC wanted = return () - | otherwise + + | otherwise -- NB: we build an implication /even if skol_tvs is empty/, + -- just to ensure that our level invariants hold, specifically + -- (WantedInv). See Note [TcLevel invariants]. = checkNoErrs $ -- Fail - do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted ; reportAllUnsolved (mkImplicWC (unitBag implic)) } @@ -677,7 +686,6 @@ Note [Safe Haskell Overlapping Instances Implementation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - How is this implemented? It's complicated! So we'll step through it all: 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where @@ -903,7 +911,7 @@ (sat, new_inerts) <- runTcSInerts inerts $ do traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env let given_cts = mkGivens given_loc (bagToList given_ids) -- See Note [Superclasses and satisfiability] solveSimpleGivens given_cts @@ -1052,7 +1060,9 @@ , pred <- sig_inst_theta sig ] ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - ; qtkvs <- quantifyTyVars DefaultNonStandardTyVars dep_vars + + ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, False) } @@ -1081,7 +1091,7 @@ <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) - -- psig_evs : see Note [Add signature contexts as givens] + -- psig_evs : see Note [Add signature contexts as wanteds] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over @@ -1104,11 +1114,17 @@ -- NB: bound_theta are constraints we want to quantify over, -- including the psig_theta, which we always quantify over -- NB: bound_theta are fully zonked - ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl + ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl name_taus partial_sigs quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + ; let full_theta = map idType bound_theta_vars + ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty) + | (name, ty) <- name_taus ]) + } + + -- Now emit the residual constraint ; emitResidualConstraints rhs_tclvl ev_binds_var name_taus co_vars qtvs bound_theta_vars @@ -1117,9 +1133,9 @@ -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> ppr bound_theta - , text "qtvs =" <+> ppr qtvs + , text "psig_theta =" <+> ppr psig_theta + , text "bound_theta =" <+> pprCoreBinders bound_theta_vars + , text "qtvs =" <+> ppr qtvs , text "definite_error =" <+> ppr definite_error ] ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } @@ -1177,12 +1193,19 @@ , let ev = ctEvidence ct ] findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType +-- Given a partial type signature f :: (C a, D a, _) => blah +-- and the inferred constraints (X a, D a, Y a, C a) +-- compute the difference, which is what will fill in the "_" underscore, +-- In this case the diff is (X a, Y a). findInferredDiff annotated_theta inferred_theta + | null annotated_theta -- Short cut the common case when the user didn't + = return inferred_theta -- write any constraints in the partial signature + | otherwise = pushTcLevelM_ $ do { lcl_env <- TcM.getLclEnv ; given_ids <- mapM TcM.newEvVar annotated_theta ; wanteds <- newWanteds AnnOrigin inferred_theta - ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env given_cts = mkGivens given_loc given_ids ; residual <- runTcSDeriveds $ @@ -1254,8 +1277,25 @@ fundeps Solution: in simplifyInfer, we add the constraints from the signature -as extra Wanteds +as extra Wanteds. +Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas +that would mess up (GivenInv) in Note [TcLevel invariants]. Consider + f :: (Eq a, _) => blah1 + f = ....g... + g :: (Eq b, _) => blah2 + g = ...f... + +Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with +TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved +all those constraints. And both have level 1, so we can't put them as +Givens when solving at level 1. + +Best to treat them as Wanteds. + +But see also #20076, which would be solved if they were Givens. + + ************************************************************************ * * Quantification @@ -1308,7 +1348,8 @@ -} decideQuantification - :: InferMode + :: SkolemInfo + -> InferMode -> TcLevel -> [(Name, TcTauType)] -- Variables to be generalised -> [TcIdSigInst] -- Partial type signatures (if any) @@ -1317,7 +1358,7 @@ , [PredType] -- and this context (fully zonked) , VarSet) -- See Note [Deciding quantification] -decideQuantification infer_mode rhs_tclvl name_taus psigs candidates +decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates = do { -- Step 1: find the mono_tvs ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode name_taus psigs candidates @@ -1327,7 +1368,7 @@ ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates + ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates -- Step 4: choose which of the remaining candidate -- predicates to actually quantify over @@ -1335,18 +1376,24 @@ -- into quantified skolems, so we have to zonk again ; candidates <- TcM.zonkTcTypes candidates ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; let quantifiable_candidates - = pickQuantifiablePreds (mkVarSet qtvs) candidates + ; let min_theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + pickQuantifiablePreds (mkVarSet qtvs) candidates - theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - psig_theta ++ quantifiable_candidates - -- NB: add psig_theta back in here, even though it's already - -- part of candidates, because we always want to quantify over - -- psig_theta, and pickQuantifiableCandidates might have - -- dropped some e.g. CallStack constraints. c.f #14658 - -- equalities (a ~ Bool) - -- Remember, this is the theta for the residual constraint + min_psig_theta = mkMinimalBySCs id psig_theta + -- Add psig_theta back in here, even though it's already + -- part of candidates, because we always want to quantify over + -- psig_theta, and pickQuantifiableCandidates might have + -- dropped some e.g. CallStack constraints. c.f #14658 + -- equalities (a ~ Bool) + -- It's helpful to use the same "find difference" algorithm here as + -- we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) + -- See Note [Constraints in partial type signatures] + ; theta <- if null psig_theta + then return min_theta -- Fast path for the non-partial-sig case + else do { diff <- findInferredDiff min_psig_theta min_theta + ; return (min_psig_theta ++ diff) } + ; traceTc "decideQuantification" (vcat [ text "infer_mode:" <+> ppr infer_mode , text "candidates:" <+> ppr candidates @@ -1357,7 +1404,39 @@ , text "theta:" <+> ppr theta ]) ; return (qtvs, theta, co_vars) } ------------------- +{- Note [Constraints in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a partial type signature + f :: (Eq a, C a, _) => blah + +We will ultimately quantify f over (Eq a, C a, ), where + + * is the result of + findInferredDiff (Eq a, C a) + in GHC.Tc.Gen.Bind.chooseInferredQuantifiers + + * is the theta returned right here, + by decideQuantification + +At least for single functions we would like to quantify f over +precisely the same theta as , so that we get to take +the short-cut path in GHC.Tc.Gen.Bind.mkExport, and avoid calling +tcSubTypeSigma for impedence matching. Why avoid? Because it falls +over for ambiguous types (#20921). + +We can get precisely the same theta by using the same algorithm, +findInferredDiff. + +All of this goes wrong if we have (a) mutual recursion, (b) mutiple +partial type signatures, (c) with different constraints, and (d) +ambiguous types. Something like + f :: forall a. Eq a => F a -> _ + f x = (undefined :: a) == g x undefined + g :: forall b. Show b => F b -> _ -> b + g x y = let _ = (f y, show x) in x +But that's a battle for another day. +-} + decideMonoTyVars :: InferMode -> [(Name,TcType)] -> [TcIdSigInst] @@ -1374,7 +1453,7 @@ -- If possible, we quantify over partial-sig qtvs, so they are -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $ + ; psig_qtvs <- zonkTcTyVarsToTcTyVars $ binderVars $ concatMap (map snd . sig_inst_skols) psigs ; psig_theta <- mapM TcM.zonkTcType $ @@ -1525,12 +1604,13 @@ ------------------ decideQuantifiedTyVars - :: [(Name,TcType)] -- Annotated theta and (name,tau) pairs + :: SkolemInfo + -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs -> [TcIdSigInst] -- Partial signatures -> [PredType] -- Candidates, zonked -> TcM [TyVar] -- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars name_taus psigs candidates +decideQuantifiedTyVars skol_info name_taus psigs candidates = do { -- Why psig_tys? We try to quantify over everything free in here -- See Note [Quantification and partial signatures] -- Wrinkles 2 and 3 @@ -1569,7 +1649,7 @@ , text "grown_tcvs =" <+> ppr grown_tcvs , text "dvs =" <+> ppr dvs_plus]) - ; quantifyTyVars DefaultNonStandardTyVars dvs_plus } + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } ------------------ growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet @@ -2130,7 +2210,7 @@ | otherwise = go (later_skols `extendVarSet` one_skol) earlier_skols -warnRedundantGivens :: SkolemInfo -> Bool +warnRedundantGivens :: SkolemInfoAnon -> Bool warnRedundantGivens (SigSkol ctxt _ _) = case ctxt of FunSigCtxt _ rrc -> reportRedundantConstraints rrc @@ -2773,7 +2853,7 @@ | Just subst <- mb_subst = do { lcl_env <- TcS.getLclEnv ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env + ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env -- Equality constraints are possible due to type defaulting plugins ; wanted_evs <- mapM (newWantedNC loc . substTy subst . ctPred) wanteds diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs --- a/compiler/GHC/Tc/Solver/Canonical.hs +++ b/compiler/GHC/Tc/Solver/Canonical.hs @@ -871,10 +871,14 @@ solveForAll ev tvs theta pred pend_sc | CtWanted { ctev_dest = dest } <- ev = -- See Note [Solving a Wanted forall-constraint] - do { let skol_info = QuantCtxtSkol - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + setLclEnv (ctLocEnv loc) $ + -- This setLclEnv is important: the emitImplicationTcS uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + do { skol_info <- mkSkolemInfo QuantCtxtSkol + ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs + ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs ; given_ev_vars <- mapM newEvVar (substTheta subst theta) ; (lvl, (w_id, wanteds)) @@ -884,7 +888,7 @@ ; return ( ctEvEvId wanted_ev , unitBag (mkNonCanonical wanted_ev)) } - ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs + ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs given_ev_vars wanteds ; setWantedEvTerm dest $ @@ -1348,11 +1352,11 @@ else do { traceTcS "Creating implication for polytype equality" $ ppr ev ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $ + ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ binderVars bndrs1 - ; let skol_info = UnifyForAllSkol phi1 - phi1' = substTy subst1 phi1 + ; let phi1' = substTy subst1 phi1 -- Unify the kinds, extend the substitution go :: [TcTyVar] -> TCvSubst -> [TyVarBinder] @@ -1380,7 +1384,7 @@ ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds + ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds ; setWantedEq orig_dest all_co ; stopWith ev "Deferred polytype equality" } } diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -52,7 +52,7 @@ getSolvedDicts, setSolvedDicts, getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, + getTopEnv, getGblEnv, getLclEnv, setLclEnv, getTcEvBindsVar, getTcLevel, getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, tcLookupClass, tcLookupId, @@ -948,10 +948,10 @@ , inert_given_eqs = given_eqs , inert_given_eq_lvl = ge_lvl }) <- getInertCans - ; let insols = filterBag insolubleEqCt irreds + ; let given_insols = filterBag insoluble_given_equality irreds -- Specifically includes ones that originated in some -- outer context but were refined to an insoluble by - -- a local equality; so do /not/ add ct_given_here. + -- a local equality; so no level-check needed -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet @@ -964,8 +964,11 @@ , text "ge_lvl:" <+> ppr ge_lvl , text "ambient level:" <+> ppr tclvl , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr insols] - ; return (has_ge, insols) } + , text "Insols:" <+> ppr given_insols] + ; return (has_ge, given_insols) } + where + insoluble_given_equality ct + = insolubleEqCt ct && isGivenCt ct {- Note [Unsolved Derived equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1225,6 +1228,9 @@ m >>= k = mkTcS $ \ebs -> do unTcS m ebs >>= (\r -> unTcS (k r) ebs) +instance MonadIO TcS where + liftIO act = TcS $ \_env -> liftIO act + instance MonadFail TcS where fail err = mkTcS $ \_ -> fail err @@ -1244,6 +1250,9 @@ -- and TcS is supposed to have limited functionality wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds +wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a +wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) + wrapErrTcS :: TcM a -> TcS a -- The thing wrapped should just fail -- There's no static check; it's up to the user @@ -1497,7 +1506,7 @@ ; return res } -emitImplicationTcS :: TcLevel -> SkolemInfo +emitImplicationTcS :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -- Skolems -> [EvVar] -- Givens -> Cts -- Wanteds @@ -1518,7 +1527,7 @@ ; emitImplication imp ; return (TcEvBinds (ic_binds imp)) } -emitTvImplicationTcS :: TcLevel -> SkolemInfo +emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -- Skolems -> Cts -- Wanteds -> TcS () @@ -1777,6 +1786,9 @@ getLclEnv :: TcS TcLclEnv getLclEnv = wrapTcS $ TcM.getLclEnv +setLclEnv :: TcLclEnv -> TcS a -> TcS a +setLclEnv env = wrap2TcS (TcM.setLclEnv env) + tcLookupClass :: Name -> TcS Class tcLookupClass c = wrapTcS $ TcM.tcLookupClass c @@ -1992,8 +2004,8 @@ matchGlobalInst dflags short_cut cls tys = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs +tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs -- Creating and setting evidence variables and CtFlavors -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -865,8 +865,10 @@ { Just (redn, fr@(_, inert_eq_rel)) | fr `eqCanRewriteFR` (flavour, eq_rel) -> - do { traceRewriteM "rewrite family application with inert" - (ppr tc <+> ppr xis $$ ppr redn) + do { traceRewriteM "rewrite family application with inert" $ + vcat [ ppr tc <+> ppr xis + , ppUnless (flavour == Derived) (ppr redn) ] + -- Deriveds have no evidence, so we can't print the reduction ; finish True (homogenise downgraded_redn) } -- this will sometimes duplicate an inert in the cache, -- but avoiding doing so had no impact on performance, and diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -23,13 +23,14 @@ tcFamTyPats, tcTyFamInstEqn, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily + wrongKindOfFamily, checkFamTelescope ) where import GHC.Prelude import GHC.Driver.Env import GHC.Driver.Session +import GHC.Driver.Config.HsToCore import GHC.Hs @@ -72,6 +73,7 @@ import GHC.Types.Error import GHC.Types.Id +import GHC.Types.Id.Make import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -86,7 +88,7 @@ import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.List.SetOps +import GHC.Data.List.SetOps( minusList, equivClasses ) import GHC.Unit @@ -97,9 +99,8 @@ import GHC.Utils.Misc import Control.Monad -import Data.Function ( on ) import Data.Functor.Identity -import Data.List (nubBy, partition) +import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap ) @@ -147,7 +148,6 @@ -- and their implicit Ids,DataCons , [InstInfo GhcRn] -- Source-code instance decls info , [DerivInfo] -- Deriving info - , ClassScopedTVEnv -- Class scoped type variables , ThBindEnv -- TH binding levels ) -- Fails if there are any errors @@ -155,30 +155,28 @@ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] emptyNameEnv emptyNameEnv tyclds_s + = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s where fold_env :: [InstInfo GhcRn] -> [DerivInfo] - -> ClassScopedTVEnv -> ThBindEnv -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv) - fold_env inst_info deriv_info class_scoped_tv_env th_bndrs [] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) + fold_env inst_info deriv_info th_bndrs [] = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) } - fold_env inst_info deriv_info class_scoped_tv_env th_bndrs (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env', th_bndrs') + ; return (gbl_env, inst_info, deriv_info, th_bndrs) } + fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s) + = do { (tcg_env, inst_info', deriv_info', th_bndrs') <- tcTyClGroup tyclds ; setGblEnv tcg_env $ -- remaining groups are typechecked in the extended global env. fold_env (inst_info' ++ inst_info) (deriv_info' ++ deriv_info) - (class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env) (th_bndrs' `plusNameEnv` th_bndrs) tyclds_s } tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv) + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds @@ -190,7 +188,7 @@ -- Step 1: Typecheck the standalone kind signatures and type/class declarations ; traceTc "---- tcTyClGroup ---- {" empty ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info, class_scoped_tv_env, kindless) <- + ; (tyclss, data_deriv_info, kindless) <- tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs ; tcTyClDecls tyclds kisig_env role_annots } @@ -226,7 +224,7 @@ ; let deriv_info = datafam_deriv_info ++ data_deriv_info ; let gbl_env'' = gbl_env' { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless } - ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env, + ; return (gbl_env'', inst_info, deriv_info, th_bndrs' `plusNameEnv` th_bndrs) } -- Gives the kind for every TyCon that has a standalone kind signature @@ -236,7 +234,7 @@ :: [LTyClDecl GhcRn] -> KindSigEnv -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo], ClassScopedTVEnv, NameSet) + -> TcM ([TyCon], [DerivInfo], NameSet) tcTyClDecls tyclds kisig_env role_annots = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class @@ -250,12 +248,11 @@ -- NB: We have to be careful here to NOT eagerly unfold -- type synonyms, as we have not tested for type synonym -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _, _, _) -> do + ; fixM $ \ ~(rec_tyclss, _, _) -> do { tcg_env <- getGblEnv -- Forced so we don't retain a reference to the TcGblEnv ; let !src = tcg_src tcg_env roles = inferRoles src role_annots rec_tyclss - class_scoped_tv_env = mk_class_scoped_tv_env tc_tycons -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons @@ -272,7 +269,7 @@ -- Kind and type check declarations for this group mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos, class_scoped_tv_env, kindless) + ; return (tycons, concat data_deriv_infos, kindless) } } where ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma @@ -280,16 +277,6 @@ , ppr (tyConResKind tc) , ppr (isTcTyCon tc) ]) - -- Map each class TcTyCon to their tcTyConScopedTyVars. This is ultimately - -- meant to be passed to GHC.Tc.TyCl.Class.tcClassDecl2, which consults - -- it when bringing type variables into scope over class method defaults. - -- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon". - mk_class_scoped_tv_env :: [TcTyCon] -> ClassScopedTVEnv - mk_class_scoped_tv_env tc_tycons = - mkNameEnv [ (tyConName tc_tycon, tcTyConScopedTyVars tc_tycon) - | tc_tycon <- tc_tycons, tyConFlavour tc_tycon == ClassFlavour - ] - zipRecTyClss :: [TcTyCon] -> [TyCon] -- Knot-tied -> [(Name,TyThing)] @@ -417,32 +404,51 @@ see makeRecoveryTyCon. 2. When checking a type/class declaration (in module GHC.Tc.TyCl), we come - upon knowledge of the eventual tycon in bits and pieces. + upon knowledge of the eventual tycon in bits and pieces, and we use + a TcTyCon to record what we know before we are ready to build the + final TyCon. - S1) First, we use inferInitialKinds to look over the user-provided - kind signature of a tycon (including, for example, the number - of parameters written to the tycon) to get an initial shape of - the tycon's kind. We record that shape in a TcTyCon. + We first build a MonoTcTyCon, then generalise to a PolyTcTyCon + See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType + Specifically: - For CUSK tycons, the TcTyCon has the final, generalised kind. - For non-CUSK tycons, the TcTyCon has as its tyConBinders only - the explicit arguments given -- no kind variables, etc. + S1) In kcTyClGroup, we use checkInitialKinds to get the + utterly-final Kind of all TyCons in the group that + (a) have a kind signature or + (b) have a CUSK. + This produces a PolyTcTyCon, that is, a TcTyCon in which the binders + and result kind are full of TyVars (not TcTyVars). No unification + variables here; everything is in its final form. - S2) Then, using these initial kinds, we kind-check the body of the - tycon (class methods, data constructors, etc.), filling in the + S2) In kcTyClGroup, we use inferInitialKinds to look over the + declaration of any TyCon that lacks a kind signature or + CUSK, to determine its "shape"; for example, the number of + parameters, and any kind signatures. + + We record that shape record that shape in a MonoTcTyCon; it is + "mono" because it has not been been generalised, and its binders + and result kind may have free unification variables. + + S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + body (class methods, data constructors, etc.) of each of + these MonoTcTyCons, which has the effect of filling in the metavariables in the tycon's initial kind. - S3) We then generalize to get the (non-CUSK) tycon's final, fixed - kind. Finally, once this has happened for all tycons in a - mutually recursive group, we can desugar the lot. + S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize + each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it, + and a final, fixed kind. - For convenience, we store partially-known tycons in TcTyCons, which - might store meta-variables. These TcTyCons are stored in the local - environment in GHC.Tc.TyCl, until the real full TyCons can be created - during desugaring. A desugared program should never have a TcTyCon. + S5) Finally, back in TcTyClDecls, we extend the environment with + the PolyTcTyCons, and typecheck each declaration (regardless + of kind signatures etc) to get final TyCon. -3. In a TcTyCon, everything is zonked after the kind-checking pass (S2). + These TcTyCons are stored in the local environment in GHC.Tc.TyCl, + until the real full TyCons can be created during desugaring. A + desugared program should never have a TcTyCon. +3. A MonoTcTyCon can contain unification variables, but a PolyTcTyCon + does not: only skolem TcTyVars. + 4. tyConScopedTyVars. A challenging piece in all of this is that we end up taking three separate passes over every declaration: - one in inferInitialKind (this pass look only at the head, not the body) @@ -457,8 +463,10 @@ GHC.Tc.Gen.HsType.splitTelescopeTvs!) Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of the TcTyCon. - These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars. + bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. + These tyvars are brought into scope by the calls to + tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) + in kcTyClDecl. In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather than just [TcTyVar]? Consider these mutually-recursive decls @@ -655,7 +663,7 @@ -} -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet) +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet) -- Kind check this group, kind generalize, and return the resulting local env -- This binds the TyCons and Classes of the group, but not the DataCons @@ -699,7 +707,7 @@ ; inferred_tcs <- tcExtendKindEnvWithTyCons checked_tcs $ - pushLevelAndSolveEqualities UnkSkol [] $ + pushLevelAndSolveEqualities unkSkolAnon [] $ -- We are going to kind-generalise, so unification -- variables in here must be one level in do { -- Step 1: Bind kind variables for all decls @@ -739,7 +747,7 @@ -- specified-tvs ++ required-tvs -- You can distinguish them because there are tyConArity required-tvs -generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon] +generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] -- See Note [Swizzling the tyvars before generaliseTcTyCon] generaliseTyClDecl inferred_tc_env (L _ decl) = do { let names_in_this_decl :: [Name] @@ -768,35 +776,38 @@ at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats at_names _ = [] -- Only class decls have associated types - skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs) + skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, 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) } + ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name ) + ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc) + ; return (tc, skol_info, scoped_prs) } - zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind) - zonk_tc_tycon (tc, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs + zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) + -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) + zonk_tc_tycon (tc, skol_info, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs -- We really have to do this again, even though - -- we have just done zonkAndSkolemise + -- we have just done zonkAndSkolemise, so that + -- occurrences in the /kinds/ get zonked to the skolem ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, scoped_prs, res_kind) } + ; return (tc, skol_info, scoped_prs, res_kind) } -swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, ScopedPairs, TcKind)] +swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] swizzleTcTyConBndrs tc_infos | all no_swizzle swizzle_prs -- This fast path happens almost all the time -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType -- "Almost all the time" means not the case of mutual recursion with -- polymorphic kinds. - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos)) + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos) ; return tc_infos } | otherwise - = do { check_duplicate_tc_binders + = do { checkForDuplicateScopedTyVars swizzle_prs ; traceTc "swizzleTcTyConBndrs" $ vcat [ text "before" <+> ppr_infos tc_infos @@ -806,49 +817,19 @@ ; return swizzled_infos } where - swizzled_infos = [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, scoped_prs, kind) <- tc_infos ] + swizzled_infos = [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, skol_info, scoped_prs, kind) <- tc_infos ] swizzle_prs :: [(Name,TyVar)] -- Pairs the user-specified Name with its representative TyVar -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] + 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 $ TcRnUnknownMessage $ mkPlainError noHints $ - 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) ] + | (tc, _, prs, _) <- infos ] -------------- The swizzler ------------ -- This does a deep traverse, simply doing a @@ -884,8 +865,10 @@ swizzle_ty ty = runIdentity (map_type ty) -generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon -generaliseTcTyCon (tc, scoped_prs, tc_res_kind) +generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon +generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind) + -- The scoped_prs are fully zonked skolem TcTyVars + -- And tc_res_kind is fully zonked too -- See Note [Required, Specified, and Inferred for types] = setSrcSpan (getSrcSpan tc) $ addTyConCtxt tc $ @@ -907,7 +890,7 @@ -- Step 2b: quantify, mainly meaning skolemise the free variables -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars DefaultNonStandardTyVars dvs2 + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2 ; traceTc "generaliseTcTyCon: pre zonk" (vcat [ text "tycon =" <+> ppr tc @@ -916,21 +899,18 @@ , text "dvs1 =" <+> ppr dvs1 , text "inferred =" <+> pprTyVars inferred ]) - -- Step 3: Final zonk (following kind generalisation) - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, inferred) <- zonkTyBndrsX ze inferred - ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs - ; (ze, req_tvs) <- zonkTyBndrsX ze req_tvs - ; tc_res_kind <- zonkTcTypeToTypeX ze tc_res_kind + -- Step 3: Final zonk: quantifyTyVars may have done some defaulting + ; inferred <- zonkTcTyVarsToTcTyVars inferred + ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs + ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs + ; tc_res_kind <- zonkTcType tc_res_kind ; traceTc "generaliseTcTyCon: post zonk" $ vcat [ text "tycon =" <+> ppr tc , text "inferred =" <+> pprTyVars inferred , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs - , text "zonk-env =" <+> ppr ze ] + , text "req_tvs =" <+> ppr req_tvs ] -- Step 4: Make the TyConBinders. ; let dep_fv_set = candidateKindVars dvs1 @@ -939,15 +919,21 @@ required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs -- Step 5: Assemble the final list. - final_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] + all_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + flav = tyConFlavour tc + -- Eta expand + ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind + -- 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) + ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon (tyConName tc) + final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + flav ; traceTc "generaliseTcTyCon done" $ vcat [ text "tycon =" <+> ppr tc @@ -1172,7 +1158,7 @@ Here we will unify k1 with k2, but this time doing so is an error, because k1 and k2 are bound in the same declaration. - We spot this during validity checking (findDupTyVarTvs), + We spot this during validity checking (checkForDuplicateScopeTyVars), in generaliseTcTyCon. * Required arguments. Even the Required arguments should be made @@ -1305,7 +1291,7 @@ -- Works for family declarations too -------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon] +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] -- Returns a TcTyCon for each TyCon bound by the decls, -- each with its initial kind @@ -1319,7 +1305,7 @@ -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon] +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] checkInitialKinds decls = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) ; tcs <- concatMapM check_initial_kind decls @@ -1350,18 +1336,17 @@ (ClassDecl { tcdLName = L _ name , tcdTyVars = ktvs , tcdATs = ats }) - = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $ + = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $ return (TheKind constraintKind) - ; let parent_tv_prs = tcTyConScopedTyVars cls -- See Note [Don't process associated types in getInitialKind] - ; inner_tcs <- - tcExtendNameTyVarEnv parent_tv_prs $ - mapM (addLocMA (getAssocFamInitialKind cls)) ats - ; return (cls : inner_tcs) } + + ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ + mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats + ; return (cls_tc : at_tcs) } where getAssocFamInitialKind cls = case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) InitialKindCheck _ -> check_initial_kind_assoc_fam cls getInitialKind strategy @@ -1561,7 +1546,7 @@ -- Called only for declarations without a signature (no CUSKs or SAKs here) kcLTyClDecl (L loc decl) = setSrcSpanA loc $ - do { tycon <- tcLookupTcTyCon tc_name + do { tycon <- tcLookupTcTyCon tc_name -- Always a MonoTcTyCon ; traceTc "kcTyClDecl {" (ppr tc_name) ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] addErrCtxt (tcMkDeclCtxt decl) $ @@ -1570,15 +1555,21 @@ where tc_name = tcdName decl -kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM () +kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () -- This function is used solely for its side effect on kind variables -- NB kind signatures on the type variables and -- result kind signature have already been dealt with -- by inferInitialKind, so we can ignore them here. -kcTyClDecl (DataDecl { tcdLName = (L _ name), tcdDataDefn = defn }) tycon +-- NB these equations just extend the type environment with carefully constructed +-- TcTyVars rather than create skolemised variables for the bound variables. +-- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars +-- - In this function, those TcTyVars are unified with other kind variables during +-- kind inference (see [How TcTyCons work]) + +kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = defn }) tycon | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn - = bindTyClTyVars name $ \ _ _ _ -> + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ -- NB: binding these tyvars isn't necessary for GADTs, but it does no -- harm. For GADTs, each data con brings its own tyvars into scope, -- and the ones from this bindTyClTyVars are either not mentioned or @@ -1588,15 +1579,16 @@ ; kcConDecls new_or_data (tyConResKind tycon) cons } -kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon - = bindTyClTyVars name $ \ _ _ res_kind -> - discardResult $ tcCheckLHsType rhs (TheKind res_kind) +kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + let res_kind = tyConResKind tycon + in discardResult $ tcCheckLHsType rhs (TheKind res_kind) -- NB: check against the result kind that we allocated -- in inferInitialKinds. -kcTyClDecl (ClassDecl { tcdLName = L _ name - , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon - = bindTyClTyVars name $ \ _ _ _ -> +kcTyClDecl (ClassDecl { tcdLName = L _ _name + , tcdCtxt = ctxt, tcdSigs = sigs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ do { _ <- tcHsContext ctxt ; mapM_ (wrapLocMA_ kc_sig) sigs } where @@ -1616,7 +1608,7 @@ -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. -kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () +kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind @@ -1625,7 +1617,7 @@ } -- Kind-check the types of arguments to a Haskell98 data constructor. -kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM () +kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM () kcConH98Args new_or_data res_kind con_args = case con_args of PrefixCon _ tys -> kcConArgTys new_or_data res_kind tys InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2] @@ -1633,14 +1625,14 @@ map (hsLinear . cd_fld_type . unLoc) flds -- Kind-check the types of arguments to a GADT data constructor. -kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM () +kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () kcConGADTArgs new_or_data res_kind con_args = case con_args of PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds kcConDecls :: NewOrData - -> Kind -- The result kind signature + -> TcKind -- The result kind signature -- Used only in H98 case -> [LConDecl GhcRn] -- The data constructors -> TcM () @@ -1654,7 +1646,7 @@ -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments. kcConDecl :: NewOrData - -> Kind -- Result kind of the type constructor + -> TcKind -- Result kind of the type constructor -- Usually Type but can be TYPE UnliftedRep -- or even TYPE r, in the case of unlifted newtype -- Used only in H98 case @@ -1680,6 +1672,7 @@ = -- See Note [kcConDecls: kind-checking data type decls] addErrCtxt (dataConCtxt names) $ discardResult $ + -- Not sure this is right, should just extend rather than skolemise but no test bindOuterSigTKBndrs_Tv outer_bndrs $ -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] do { _ <- tcHsContext cxt @@ -2181,7 +2174,7 @@ Note that, in the GADT case, we might have a kind signature with arrows (newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon +component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon in kcTyClDecl. STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function @@ -2420,16 +2413,15 @@ -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> - -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ _ binders res_kind -> + = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ binders res_kind -> do { checkClassKindSig res_kind ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) ; let tycon_name = class_name -- We use the same name roles = roles_info tycon_name -- for TyCon and Class ; (ctxt, fds, sig_stuff, at_stuff) - <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ + <- pushLevelAndSolveEqualities skol_info binders $ -- The (binderVars binders) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt @@ -2485,6 +2477,7 @@ ; return clas } where skol_info = TyConSkol ClassFlavour class_name + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) tc_fundep (FunDep _ tvs1 tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; @@ -2708,7 +2701,7 @@ , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { traceTc "tcFamDecl1 data family:" (ppr tc_name) ; checkFamFlag tc_name @@ -2734,7 +2727,7 @@ ; return tycon } | OpenTypeFamily <- fam_info - = bindTyClTyVars tc_name $ \ _ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { traceTc "tcFamDecl1 open type family:" (ppr tc_name) ; checkFamFlag tc_name ; inj' <- tcInjectivity binders inj @@ -2751,7 +2744,7 @@ -- the variables in the header scope only over the injectivity -- declaration but this is not involved here ; (inj', binders, res_kind) - <- bindTyClTyVars tc_name $ \ _ binders res_kind -> + <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do { inj' <- tcInjectivity binders inj ; return (inj', binders, res_kind) } @@ -2838,7 +2831,7 @@ text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds + ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars closeOverKinds (mkVarSet inj_tvs) ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs @@ -2849,10 +2842,10 @@ tcTySynRhs :: RolesInfo -> Name -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ _ binders res_kind -> + = bindTyClTyVars tc_name $ \ binders res_kind -> do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ + ; rhs_ty <- pushLevelAndSolveEqualities skol_info binders $ tcCheckLHsType hs_ty (TheKind res_kind) -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType @@ -2866,8 +2859,9 @@ , ppr rhs_ty ] ) } ; doNotQuantifyTyVars dvs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, binders) <- zonkTyVarBindersX ze binders + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty ; let roles = roles_info tc_name ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) } where @@ -2883,26 +2877,20 @@ -- via inferInitialKinds , dd_cons = cons , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind -> - -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need - -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon' - -- + = bindTyClTyVars tc_name $ \ tc_bndrs 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 - -- see Note [Datatype return kinds] - ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind ; tcg_env <- getGblEnv ; let hsc_src = tcg_src tcg_env ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) final_res_kind + checkDataKindSig (DataDeclSort new_or_data) res_kind - ; let skol_tvs = binderVars tycon_binders - ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $ + ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ tcHsContext ctxt -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType @@ -2917,36 +2905,39 @@ , pprTheta theta ] ) } ; doNotQuantifyTyVars dvs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta - -- Check that we don't use kind signatures without the extension ; kind_signatures <- xoptM LangExt.KindSignatures ; when (isJust mb_ksig) $ checkTc (kind_signatures) (badSigTyDecl tc_name) + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta + ; res_kind <- zonkTcTypeToTypeX ze res_kind + ; tycon <- fixM $ \ rec_tycon -> do - { let final_bndrs = tycon_binders `chkAppend` extra_bndrs - roles = roles_info tc_name - ; data_cons <- tcConDecls - new_or_data DDataType - rec_tycon final_bndrs final_res_kind - cons + { data_cons <- tcConDecls new_or_data DDataType rec_tycon + tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name + ; return (mkAlgTyCon tc_name - final_bndrs - final_res_kind - roles + bndrs + res_kind + (roles_info tc_name) (fmap unLoc cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) } - ; let deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = tcTyConScopedTyVars tctc + gadt_syntax) + } + + ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs) + -- scoped_tvs: still the skolem TcTyVars + deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = scoped_tvs , di_clauses = derivs , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs) ; return (tycon, [deriv_info]) } where skol_info = TyConSkol flav tc_name @@ -3092,7 +3083,7 @@ So, we use bindOuterFamEqnTKBndrs (which does not create an implication for the telescope), and generalise over /all/ the variables in the LHS, -without treating the explicitly-quanfitifed ones specially. Wrinkles: +without treating the explicitly-quantifed ones specially. Wrinkles: - When generalising, include the explicit user-specified forall'd variables, so that we get an error from Validity.checkFamPatBinders @@ -3123,16 +3114,17 @@ -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats) -- By now, for type families (but not data families) we should -- have checked that the number of patterns matches tyConArity + ; skol_info <- mkSkolemInfo FamInstSkol -- This code is closely related to the code -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk - ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty))) + ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty))) <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $ - bindOuterFamEqnTKBndrs outer_hs_bndrs $ + bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $ do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats -- Ensure that the instance is consistent with its -- parent class (#16008) @@ -3140,6 +3132,12 @@ ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) ; return (lhs_ty, rhs_ty) } + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + + ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info) + -- This code (and the stuff immediately above) is very similar -- to that in tcDataFamInstHeader. Maybe we should abstract the -- common code; but for the moment I concluded that it's @@ -3147,15 +3145,17 @@ -- check there too! -- See Note [Generalising in tcTyFamInstEqnGuts] - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs) - ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs - ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted - ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted ; traceTc "tcTyFamInstEqnGuts 2" $ vcat [ ppr fam_tc - , text "lhs_ty" <+> ppr lhs_ty - , text "qtvs" <+> pprTyVars qtvs ] + , text "lhs_ty:" <+> ppr lhs_ty + , text "final_tvs:" <+> pprTyVars final_tvs ] -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType -- Example: typecheck/should_fail/T17301 @@ -3167,20 +3167,24 @@ , ppr rhs_ty ] ) } ; doNotQuantifyTyVars dvs_rhs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qtvs) <- zonkTyBndrsX ze qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, final_tvs) <- zonkTyBndrsX ze final_tvs + ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty ; let pats = unravelFamInstPats lhs_ty -- Note that we do this after solveEqualities -- so that any strange coercions inside lhs_ty -- have been solved before we attempt to unravel it - ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) - ; return (qtvs, pats, rhs_ty) } + ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ]) + -- Don't try to print 'pats' here, because lhs_ty involves + -- a knot-tied type constructor, so we get a black hole -checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn + ; return (final_tvs, pats, rhs_ty) } + +checkFamTelescope :: TcLevel + -> HsOuterFamEqnTyVarBndrs GhcRn -> [TcTyVar] -> TcM () -- Emit a constraint (forall a b c. ), so that -- we will do telescope-checking on a,b,c @@ -3189,9 +3193,9 @@ | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs , (b_first : _) <- bndrs , let b_last = last bndrs - skol_info = ForAllSkol (fsep (map ppr bndrs)) - = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ - emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC + = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs)) + ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do + emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC } | otherwise = return () @@ -3200,11 +3204,11 @@ -- Decompose fam_app to get the argument patterns -- -- We expect fam_app to look like (F t1 .. tn) --- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern +-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern unravelFamInstPats fam_app - = case splitTyConApp_maybe fam_app of + = case tcSplitTyConApp_maybe fam_app of Just (_, pats) -> pats Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" -- The Nothing case cannot happen for type families, because @@ -3361,7 +3365,7 @@ tcConDecls :: NewOrData -> DataDeclInfo -> KnotTied TyCon -- Representation TyCon - -> [TyConBinder] -- Binders of representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon -> TcKind -- Result kind -> [LConDecl GhcRn] -> TcM [DataCon] tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind @@ -3374,7 +3378,7 @@ tcConDecl :: NewOrData -> DataDeclInfo -> KnotTied TyCon -- Representation tycon. Knot-tied! - -> [TyConBinder] -- Binders of representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon -> TcKind -- Result kind -> NameEnv ConTag -> ConDecl GhcRn @@ -3394,11 +3398,14 @@ -- hs_qvars = HsQTvs { hsq_implicit = {k} -- , hsq_explicit = {f,b} } - ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) + ; traceTc "tcConDecl 1" (vcat [ ppr name + , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms + , text "tc_bndrs" <+> ppr tc_bndrs ]) + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms))) ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ - tcExplicitTKBndrs explicit_tkv_nms $ + tcExplicitTKBndrs skol_info explicit_tkv_nms $ do { ctxt <- tcHsContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind ; btys <- tcConH98Args exp_kind hs_args @@ -3425,10 +3432,10 @@ -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- kindGeneralizeAll fake_ty + ; kvs <- kindGeneralizeAll skol_info fake_ty - ; let skol_tvs = tc_tvs ++ kvs ++ binderVars exp_tvbndrs - ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + ; let all_skol_tvs = tc_tvs ++ kvs + ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted -- The skol_info claims that all the variables are bound -- by the data constructor decl, whereas actually the -- univ_tvs are bound by the data type decl itself. It @@ -3437,16 +3444,17 @@ -- See test dependent/should_fail/T13780a -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qkvs) <- zonkTyBndrsX ze kvs - ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, tc_bndrs) <- zonkTyVarBindersX ze tc_bndrs + ; (ze, kvs) <- zonkTyBndrsX ze kvs + ; (ze, exp_tvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let univ_tvbs = tyConInvisTVBinders tc_bndrs - ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ user_qtvbndrs + ex_tvbs = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs ex_tvs = binderVars ex_tvbs -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. @@ -3458,8 +3466,10 @@ ; is_infix <- tcConIsInfixH98 name hs_args ; rep_nm <- newTyConRepName name ; fam_envs <- tcGetFamInstEnvs - ; dc <- buildDataCon fam_envs name is_infix rep_nm - stricts Nothing field_lbls + ; dflags <- getDynFlags + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm + stricts field_lbls tc_tvs ex_tvs user_tvbs [{- no eq_preds -}] ctxt arg_tys user_res_ty rep_tycon tag_map @@ -3468,8 +3478,6 @@ -- that way checkValidDataCon can complain if it's wrong. ; return [dc] } - where - skol_info = DataConSkol name tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map -- NB: don't use res_kind here, as it's ill-scoped. Instead, @@ -3481,7 +3489,7 @@ = addErrCtxt (dataConCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names - + ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ tcOuterTKBndrs skol_info outer_hs_bndrs $ @@ -3511,12 +3519,14 @@ ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } - ; outer_tv_bndrs <- scopedSortOuter outer_bndrs + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs - ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ - res_ty) + ; tkvs <- kindGeneralizeAll skol_info + (mkInvisForAllTys outer_tv_bndrs $ + mkPhiTy ctxt $ + mkVisFunTys arg_tys $ + res_ty) ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3541,14 +3551,15 @@ -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; fam_envs <- tcGetFamInstEnvs + ; dflags <- getDynFlags ; let buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args ; rep_nm <- newTyConRepName name - ; buildDataCon fam_envs name is_infix - rep_nm - stricts Nothing field_lbls + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; buildDataCon fam_envs bang_opts name is_infix + rep_nm stricts field_lbls univ_tvs ex_tvs tvbndrs' eq_preds ctxt' arg_tys' res_ty' rep_tycon tag_map -- NB: we put data_tc, the type constructor gotten from the @@ -3556,8 +3567,6 @@ -- that way checkValidDataCon can complain if it's wrong. } ; mapM buildOneDataCon names } - where - skol_info = DataConSkol (unLoc (head names)) {- Note [GADT return types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3644,7 +3653,7 @@ -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point -- in Note [Implementation of UnliftedNewtypes] -getArgExpKind :: NewOrData -> Kind -> ContextKind +getArgExpKind :: NewOrData -> TcKind -> ContextKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind @@ -4412,7 +4421,7 @@ ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM () check_bang orig_arg_ty bang rep_bang n | HsSrcBang _ _ SrcLazy <- bang - , not (xopt LangExt.StrictData dflags) + , not (bang_opt_strict_data bang_opts) = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ (bad_bang n (text "Lazy annotation (~) without StrictData")) @@ -4434,7 +4443,7 @@ -- If not optimising, we don't unpack (rep_bang is never -- HsUnpack), so don't complain! This happens, e.g., in Haddock. -- See dataConSrcToImplBang. - , not (gopt Opt_OmitInterfacePragmas dflags) + , not (bang_opt_unbox_disable bang_opts) -- When typechecking an indefinite package in Backpack, we -- may attempt to UNPACK an abstract type. The test here will -- conclude that this is unusable, but it might become usable @@ -4479,11 +4488,12 @@ Just (f, _) -> ppr (tyConBinders f) ] } where + bang_opts = initBangOpts dflags con_name = dataConName con con_loc = nameSrcSpan con_name ctxt = ConArgCtxt con_name is_strict = \case - NoSrcStrict -> xopt LangExt.StrictData dflags + NoSrcStrict -> bang_opt_strict_data bang_opts bang -> isSrcStrict bang bad_bang n herald @@ -4625,7 +4635,8 @@ pred_tvs = tyCoVarsOfType pred check_at (ATI fam_tc m_dflt_rhs) - = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) + = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) + ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) (noClassTyVarErr cls fam_tc) -- Check that the associated type mentions at least -- one of the class type variables diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -36,7 +36,6 @@ import GHC.Core.Multiplicity import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) -import GHC.Driver.Session import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply import GHC.Utils.Misc @@ -137,12 +136,11 @@ ------------------------------------------------------ buildDataCon :: FamInstEnvs + -> DataConBangOpts -> Name -> Bool -- Declared infix -> TyConRepName -> [HsSrcBang] - -> Maybe [HsImplBang] - -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make -> [FieldLabel] -- Field labels -> [TyVar] -- Universals -> [TyCoVar] -- Existentials @@ -160,7 +158,7 @@ -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) -buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs +buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty rep_tycon tag_map = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc @@ -171,7 +169,6 @@ ; traceIf (text "buildDataCon 1" <+> ppr src_name) ; us <- newUniqueSupply - ; dflags <- getDynFlags ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 @@ -181,8 +178,7 @@ arg_tys res_ty NoRRI rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name - impl_bangs data_con) + dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } @@ -343,14 +339,15 @@ rec_tycon = classTyCon rec_clas univ_bndrs = tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs + bang_opts = FixedBangOpts (map (const HsLazy) args) ; rep_nm <- newTyConRepName datacon_name ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") + bang_opts datacon_name False -- Not declared infix rep_nm (map (const no_bang) args) - (Just (map (const HsLazy) args)) [{- No fields -}] univ_tvs [{- no existentials -}] diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -13,7 +13,6 @@ module GHC.Tc.TyCl.Class ( tcClassSigs , tcClassDecl2 - , ClassScopedTVEnv , findMethodBind , instantiateMethod , tcClassMinimalDef @@ -39,7 +38,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( piResultTys, substTyVar ) +import GHC.Core.Type ( piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin @@ -68,7 +67,6 @@ import GHC.Types.Basic import GHC.Data.Bag import GHC.Data.BooleanFormula -import GHC.Utils.Misc import Control.Monad import Data.List ( mapAccumL, partition ) @@ -189,16 +187,10 @@ ************************************************************************ -} --- | Maps class names to the type variables that scope over their bodies. --- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon". -type ClassScopedTVEnv = NameEnv [(Name, TyVar)] - -tcClassDecl2 :: ClassScopedTVEnv -- Class scoped type variables - -> LTyClDecl GhcRn -- The class declaration +tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration -> TcM (LHsBinds GhcTc) -tcClassDecl2 class_scoped_tv_env - (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, +tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan (getLocA class_name) $ @@ -212,32 +204,26 @@ -- dm1 = \d -> case ds d of (a,b,c) -> a -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each + + ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name)) + ; tc_lvl <- getTcLevel ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragEnv sigs default_binds sig_fn = mkHsSigFun sigs - (skol_subst, clas_tyvars) = tcSuperSkolTyVars tyvars + (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars + -- This make skolemTcTyVars, but does not clone, + -- so we can put them in scope with tcExtendTyVarEnv pred = mkClassPred clas (mkTyVarTys clas_tyvars) - scoped_tyvars = - case lookupNameEnv class_scoped_tv_env (unLoc class_name) of - Just tvs -> tvs - Nothing -> pprPanic "tcClassDecl2: Class name not in tcg_class_scoped_tvs_env" - (ppr class_name) - -- The substitution returned by tcSuperSkolTyVars maps each type - -- variable to a TyVarTy, so it is safe to call getTyVar below. - scoped_clas_tyvars = - mapSnd ( getTyVar ("tcClassDecl2: Super-skolem substitution maps " - ++ "type variable to non-type variable") - . substTyVar skol_subst ) scoped_tyvars ; this_dict <- newEvVar pred ; let tc_item = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn - ; dm_binds <- tcExtendNameTyVarEnv scoped_clas_tyvars $ + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_item op_items ; return (unionManyBags dm_binds) } -tcClassDecl2 _ d = pprPanic "tcClassDecl2" (ppr d) +tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -26,7 +26,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) -import GHC.Tc.TyCl.Class ( tcClassDecl2, ClassScopedTVEnv, tcATDefault, +import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, HsSigFun, mkHsSigFun, badMethodErr, findMethodBind, instantiateMethod ) import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) @@ -492,8 +492,8 @@ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance - - ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars + ; skol_info <- mkSkolemInfo InstSkol + ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info 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. @@ -691,8 +691,9 @@ ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in GHC.Core.FamInstEnv - ; (qtvs, pats, res_kind, stupid_theta) - <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity + ; skol_info <- mkSkolemInfo FamInstSkol + ; (qtvs, pats, tc_res_kind, stupid_theta) + <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data -- Eta-reduce the axiom if possible @@ -702,7 +703,7 @@ post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs - (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind)) + (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind)) ++ eta_tcbs -- Put the eta-removed tyvars at the end -- Remember, qtvs is in arbitrary order, except kind vars are @@ -718,15 +719,40 @@ -- we did it before the "extra" tvs from etaExpandAlgTyCon -- would always be eta-reduced -- - ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind + ; let flav = newOrDataToFlavour new_or_data + ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind -- Check the result kind; it may come from a user-written signature. -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) - ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs - all_pats = pats `chkAppend` extra_pats - orig_res_ty = mkTyConApp fam_tc all_pats - ty_binders = full_tcbs `chkAppend` extra_tcbs + ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs + all_pats = pats `chkAppend` extra_pats + orig_res_ty = mkTyConApp fam_tc all_pats + tc_ty_binders = full_tcbs `chkAppend` extra_tcbs + ; traceTc "tcDataFamInstDecl 1" $ + vcat [ text "Fam tycon:" <+> ppr fam_tc + , text "Pats:" <+> ppr pats + , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats) + , text "all_pats:" <+> ppr all_pats + , text "tc_ty_binders" <+> ppr tc_ty_binders + , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) + , text "tc_res_kind:" <+> ppr tc_res_kind + , text "eta_pats" <+> ppr eta_pats + , text "eta_tcbs" <+> ppr eta_tcbs ] + + -- Zonk the patterns etc into the Type world + ; ze <- mkEmptyZonkEnv NoFlexi + ; (ze, ty_binders) <- zonkTyVarBindersX ze tc_ty_binders + ; res_kind <- zonkTcTypeToTypeX ze tc_res_kind + ; all_pats <- zonkTcTypesToTypesX ze all_pats + ; eta_pats <- zonkTcTypesToTypesX ze eta_pats + ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta + ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs + zonked_eta_tvs = map (lookupTyVarX ze) eta_tvs + -- All these qtvs are in ty_binders, and hence will be in + -- the ZonkEnv, ze. We need the zonked (TyVar) versions to + -- put in the CoAxiom that we are about to build. + ; traceTc "tcDataFamInstDecl" $ vcat [ text "Fam tycon:" <+> ppr fam_tc , text "Pats:" <+> ppr pats @@ -735,16 +761,14 @@ , text "ty_binders" <+> ppr ty_binders , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc) , text "res_kind:" <+> ppr res_kind - , text "final_res_kind:" <+> ppr final_res_kind , text "eta_pats" <+> ppr eta_pats , text "eta_tcbs" <+> ppr eta_tcbs ] - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcExtendTyVarEnv qtvs $ + do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors tcConDecls new_or_data (DDataInstance orig_res_ty) - rec_rep_tc ty_binders final_res_kind + rec_rep_tc tc_ty_binders tc_res_kind hs_cons ; rep_tc_name <- newFamInstTyConName lfam_name pats @@ -752,20 +776,21 @@ ; tc_rhs <- case new_or_data of DataType -> return $ mkLevPolyDataTyConRhs - (isFixedRuntimeRepKind final_res_kind) + (isFixedRuntimeRepKind res_kind) data_cons NewType -> assert (not (null data_cons)) $ mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) - ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs) + ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs) axiom = mkSingleCoAxiom Representational axiom_name - post_eta_qtvs eta_tvs [] fam_tc eta_pats ax_rhs + zonked_post_eta_qtvs zonked_eta_tvs + [] fam_tc eta_pats ax_rhs parent = DataFamInstTyCon axiom fam_tc all_pats -- NB: Use the full ty_binders from the pats. See bullet toward -- the end of Note [Data type families] in GHC.Core.TyCon rep_tc = mkAlgTyCon rep_tc_name - ty_binders final_res_kind + ty_binders res_kind (map (const Nominal) ty_binders) (fmap unLoc cType) stupid_theta tc_rhs parent @@ -862,21 +887,23 @@ ----------------------- tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn + :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn -> LexicalFixity -> Maybe (LHsContext GhcRn) -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> NewOrData - -> TcM ([TyVar], [Type], Kind, ThetaType) + -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType) + -- All skolem TcTyVars, all zonked so it's clear what the free vars are + -- The "header" of a data family instance is the part other than -- the data constructors themselves -- e.g. data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where" -tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity +tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats) - ; (tclvl, wanted, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) + ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $ - bindOuterFamEqnTKBndrs outer_bndrs $ + bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs $ -- Binds skolem TcTyVars do { stupid_theta <- tcHsContext hs_ctxt ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats ; (lhs_applied_ty, lhs_applied_kind) @@ -898,15 +925,19 @@ -- is compatible with the explicit signature (or Type, if there -- is none) ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats - ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind + ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind ; traceTc "tcDataFamInstHeader" $ - vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ] + vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig] ; return ( stupid_theta , lhs_applied_ty , lhs_applied_kind , res_kind ) } + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs + -- This code (and the stuff immediately above) is very similar -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the -- common code; but for the moment I concluded that it's @@ -914,34 +945,30 @@ -- check there too! -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] - ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs) - ; qtvs <- quantifyTyVars TryNotToDefaultNonStandardTyVars dvs - ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted - - -- Zonk the patterns etc into the Type world - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, qtvs) <- zonkTyBndrsX ze qtvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind - ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted - -- We check that res_kind is OK with checkDataKindSig in - -- tcDataFamInstDecl, after eta-expansion. We need to check that - -- it's ok because res_kind can come from a user-written kind signature. - -- See Note [Datatype return kinds], point (4a) + ; final_tvs <- zonkTcTyVarsToTcTyVars final_tvs + ; lhs_ty <- zonkTcType lhs_ty + ; master_res_kind <- zonkTcType master_res_kind + ; instance_res_kind <- zonkTcType instance_res_kind + ; stupid_theta <- zonkTcTypes stupid_theta + -- Check that res_kind is OK with checkDataKindSig. We need to + -- check that it's ok because res_kind can come from a user-written + -- kind signature. See Note [Datatype return kinds], point (4a) ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind - -- Check that type patterns match the class instance head - -- The call to splitTyConApp_maybe here is just an inlining of - -- the body of unravelFamInstPats. - ; pats <- case splitTyConApp_maybe lhs_ty of - Just (_, pats) -> pure pats - Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty) + -- Split up the LHS type to get the type patterns + -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts] + ; let pats = unravelFamInstPats lhs_ty - ; return (qtvs, pats, master_res_kind, stupid_theta) } + ; return (final_tvs, pats, master_res_kind, stupid_theta) } where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name @@ -960,11 +987,9 @@ -- See Note [Result kind signature for a data family instance] tc_kind_sig (Just hs_kind) = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind - ; lvl <- getTcLevel - ; let (tvs, inner_kind) = tcSplitForAllInvisTyVars sig_kind - ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs - -- Perhaps surprisingly, we don't need the skolemised tvs themselves - ; return (substTy subst inner_kind) } + ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind + -- Perhaps surprisingly, we don't need the skolemised tvs themselves + ; return inner_kind' } {- Note [Result kind signature for a data family instance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1166,17 +1191,17 @@ * * ********************************************************************* -} -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> ClassScopedTVEnv +tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> TcM (LHsBinds GhcTc) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl -- generate the dfun binding -tcInstDecls2 tycl_decls inst_decls class_scoped_tv_env +tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; dm_binds_s <- mapM (tcClassDecl2 class_scoped_tv_env) class_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls ; let dm_binds = unionManyBags dm_binds_s -- (b) instance declarations @@ -1211,7 +1236,8 @@ setSrcSpan loc $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id + ; skol_info <- mkSkolemInfo InstSkol + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id ; dfun_ev_vars <- newEvVars dfun_theta -- We instantiate the dfun_id with superSkolems. -- See Note [Subtle interaction of recursion and overlap] diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -393,13 +393,18 @@ ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $ TcRnLinearPatSyn sig_body_ty + ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) + -- The type here is a bit bogus, but we do not print + -- the type for PatSynCtxt, so it doesn't matter + -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" + -- Skolemise the quantified type variables. This is necessary -- in order to check the actual pattern type against the -- expected type. Even though the tyvars in the type are -- already skolems, this step changes their TcLevels, -- avoiding level-check errors when unifying. - ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs - ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_subst0 ex_bndrs + ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs + ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs ; let skol_univ_tvs = binderVars skol_univ_bndrs skol_ex_tvs = binderVars skol_ex_bndrs skol_req_theta = substTheta skol_subst0 req_theta @@ -436,11 +441,7 @@ skol_arg_tys ; return (ex_tvs', prov_dicts, args') } - ; let skol_info = SigSkol (PatSynCtxt name) pat_ty [] - -- The type here is a bit bogus, but we do not print - -- the type for PatSynCtxt, so it doesn't matter - -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin" - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs + ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs req_dicts wanted -- Solve the constraints now, because we are about to make a PatSyn, @@ -480,15 +481,15 @@ -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag] +skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym] -skolemiseTvBndrsX orig_subst tvs +skolemiseTvBndrsX skol_info orig_subst tvs = do { tc_lvl <- getTcLevel ; let pushed_lvl = pushTcLevel tc_lvl - details = SkolemTv pushed_lvl False + details = SkolemTv skol_info pushed_lvl False mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag -> (TCvSubst, VarBndr TcTyVar flag) diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -651,6 +651,8 @@ -- recurring into coercions. Recall: coercions are totally ignored during -- role inference. See [Coercions in role inference] get_ty_vars :: Type -> FV + get_ty_vars t | Just t' <- coreView t -- #20999 + = get_ty_vars t' get_ty_vars (TyVarTy tv) = unitFV tv get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2 diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -229,14 +229,14 @@ mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) -- Based off of 'simplifyDeriv' let ty = idType (instanceDFunId sig_inst) - skol_info = InstSkol -- Based off of tcSplitDFunTy (tvs, theta, pred) = case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> case splitFunTys rho of { (theta, pred) -> (tvs, theta, pred) }} origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + skol_info <- mkSkolemInfo InstSkol + (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize (tclvl,cts) <- pushTcLevelM $ do wanted <- newWanted origin (Just TypeLevel) @@ -253,7 +253,7 @@ return $ wanted : givens unsolved <- simplifyWantedsTcM cts - (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved reportAllUnsolved (mkImplicWC implic) -- | For a module @modname@ of type 'HscSource', determine the list diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -536,6 +536,7 @@ -- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside + -- MP: This silently coerces TyVar to TcTyVar. = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r @@ -638,29 +639,28 @@ -- that are bound together with extra_env and should not be regarded -- as free in the types of extra_env. = do { traceTc "tc_extend_local_env" (ppr extra_env) - ; stage <- getStage - ; env0@(TcLclEnv { tcl_rdr = rdr_env - , tcl_th_bndrs = th_bndrs - , tcl_env = lcl_type_env }) <- getLclEnv - - ; let thlvl = (top_lvl, thLevel stage) - - env1 = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env - [ n | (n, _) <- extra_env, isInternalName n ] - -- The LocalRdrEnv contains only non-top-level names - -- (GlobalRdrEnv handles the top level) - - , tcl_th_bndrs = extendNameEnvList th_bndrs - [(n, thlvl) | (n, ATcId {}) <- extra_env] - -- We only track Ids in tcl_th_bndrs + ; updLclEnv upd_lcl_env thing_inside } + where + upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt = stage + , tcl_rdr = rdr_env + , tcl_th_bndrs = th_bndrs + , tcl_env = lcl_type_env }) + = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env + [ n | (n, _) <- extra_env, isInternalName n ] + -- The LocalRdrEnv contains only non-top-level names + -- (GlobalRdrEnv handles the top level) - , tcl_env = extendNameEnvList lcl_type_env extra_env } + , tcl_th_bndrs = extendNameEnvList th_bndrs + [(n, thlvl) | (n, ATcId {}) <- extra_env] + -- We only track Ids in tcl_th_bndrs + , tcl_env = extendNameEnvList lcl_type_env extra_env } -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and -- Template Haskell staging env simultaneously. Reason for extending -- LocalRdrEnv: after running a TH splice we need to do renaming. + where + thlvl = (top_lvl, thLevel stage) - ; setLclEnv env1 thing_inside } tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things @@ -746,7 +746,7 @@ = do { let (env', occ') = tidyOccName env (nameOccName name) name' = tidyNameOcc name occ' tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTyVar tyvar1 + ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 -- Be sure to zonk here! Tidying applies to zonked -- types, so if we don't zonk we may create an -- ill-kinded type (#14175) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -19,7 +19,8 @@ newWanted, newWanteds, tcInstType, tcInstTypeBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, + tcSkolemiseInvisibleBndrs, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -168,13 +169,14 @@ -} -topSkolemise :: TcSigmaType +topSkolemise :: SkolemInfo + -> TcSigmaType -> TcM ( HsWrapper , [(Name,TyVar)] -- All skolemised variables , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Skolemisation] -topSkolemise ty +topSkolemise skolem_info ty = go init_subst idHsWrapper [] [] ty where init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) @@ -183,7 +185,7 @@ go subst wrap tv_prs ev_vars ty | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty , not (null tvs && null theta) - = do { (subst', tvs1) <- tcInstSkolTyVarsX subst tvs + = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1) @@ -496,70 +498,99 @@ = do { (subst', tv') <- newMetaTyVarTyVarX subst tv ; return (subst', Bndr tv' spec) } -tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) +-------------------------- +tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. -- This freshens the names, but no need to do so -tcSkolDFunType dfun - = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun +tcSkolDFunType skol_info dfun + = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun ; return (map snd tv_prs, theta, tau) } -tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar]) +tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above --- Moreover, make them "super skolems"; see comments with superSkolemTv --- see Note [Kind substitution when instantiating] +-- As always, allocate them one level in +-- Moreover, make them "super skolems"; see GHC.Core.InstEnv +-- Note [Binding when looking up instances] +-- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst - -tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar) -tcSuperSkolTyVar subst tv - = (extendTvSubstWithClone subst tv new_tv, new_tv) +tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst where - kind = substTyUnchecked subst (tyVarKind tv) - new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv + details = SkolemTv skol_info (pushTcLevel tc_lvl) + True -- The "super" bit + do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv) + where + kind = substTyUnchecked subst (tyVarKind tv) + new_tv = mkTcTyVar (tyVarName tv) kind details -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst +tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst -tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False +tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. -tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst +tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst -tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. -tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst +tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst -tcInstSkolTyVarsPushLevel :: Bool -- True <=> make "super skolem" +tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool -- True <=> make "super skolem" -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables] -tcInstSkolTyVarsPushLevel overlappable subst tvs +tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs = do { tc_lvl <- getTcLevel -- Do not retain the whole TcLclEnv ; let !pushed_lvl = pushTcLevel tc_lvl - ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } + ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } -tcInstSkolTyVarsAt :: TcLevel -> Bool +tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -tcInstSkolTyVarsAt lvl overlappable subst tvs +tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs = freshenTyCoVarsX new_skol_tv subst tvs where - details = SkolemTv lvl overlappable - new_skol_tv name kind = mkTcTyVar name kind details + sk_details = SkolemTv skol_info lvl overlappable + new_skol_tv name kind = mkTcTyVar name kind sk_details +tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType) +-- Skolemise the outer invisible binders of a type +-- Do /not/ freshen them, because their scope is broader than +-- just this type. It's a bit dubious, but used in very limited ways. +tcSkolemiseInvisibleBndrs skol_info ty + = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty + ; lvl <- getTcLevel + ; skol_info <- mkSkolemInfo skol_info + ; let details = SkolemTv skol_info lvl False + mk_skol_tv name kind = return (mkTcTyVar name kind details) -- No freshening + ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs + ; return (tvs', substTy subst body_ty) } + +instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar) + -> TCvSubst -> [TyVar] + -> TcM (TCvSubst, [TcTyVar]) +-- Instantiate each type variable in turn with the specified function +instantiateTyVarsX mk_tv subst tvs + = case tvs of + [] -> return (subst, []) + (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv) + ; tv' <- mk_tv (tyVarName tv) kind1 + ; let subst1 = extendTCvSubstWithClone subst tv tv' + ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs + ; return (subst', tv':tvs') } + ------------------ freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay @@ -580,25 +611,21 @@ freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) -> TCvSubst -> [TyCoVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv) - -freshenTyCoVarX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables] -freshenTyCoVarX mk_tcv subst tycovar - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let old_name = tyVarName tycovar - -- Force so we don't retain reference to the old name and id - -- See (#19619) for more discussion - !old_occ_name = getOccName old_name - new_name = mkInternalName uniq old_occ_name loc - new_kind = substTyUnchecked subst (tyVarKind tycovar) - new_tcv = mk_tcv new_name new_kind - subst1 = extendTCvSubstWithClone subst tycovar new_tcv - ; return (subst1, new_tcv) } +freshenTyCoVarsX mk_tcv + = instantiateTyVarsX freshen_tcv + where + freshen_tcv :: Name -> Kind -> TcM TcTyVar + freshen_tcv name kind + = do { loc <- getSrcSpanM + ; uniq <- newUnique + ; let !occ_name = getOccName name + -- Force so we don't retain reference to the old + -- name and id. See (#19619) for more discussion + new_name = mkInternalName uniq occ_name loc + ; return (mk_tcv new_name kind) } {- Note [Skolemising type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -20,9 +20,9 @@ -- * Simple accessors discardResult, getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, + setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv, updTopFlags, - getEnvs, setEnvs, + getEnvs, setEnvs, updEnvs, restoreEnvs, xoptM, doptM, goptM, woptM, setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, whenDOptM, whenGOptM, whenWOptM, @@ -109,7 +109,7 @@ emitHole, emitHoles, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, - pushTcLevelM_, pushTcLevelM, pushTcLevelsM, + pushTcLevelM_, pushTcLevelM, getTcLevel, setTcLevel, isTouchableTcM, getLclTypeEnv, setLclTypeEnv, traceTcConstraints, @@ -189,7 +189,6 @@ import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc import GHC.Utils.Logger import qualified GHC.Data.Strict as Strict @@ -483,7 +482,7 @@ updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> env { env_gbl = upd gbl }) -setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) getLclEnv :: TcRnIf gbl lcl lcl @@ -493,15 +492,66 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> env { env_lcl = upd lcl }) + setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) +restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a +-- See Note [restoreLclEnv vs setLclEnv] +restoreLclEnv new_lcl_env = updLclEnv upd + where + upd old_lcl_env = new_lcl_env { tcl_errs = tcl_errs old_lcl_env + , tcl_lie = tcl_lie old_lcl_env + , tcl_usage = tcl_usage old_lcl_env } + getEnvs :: TcRnIf gbl lcl (gbl, lcl) getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a -setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) +setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env +updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updEnvs upd_envs = updEnv upd + where + upd env@(Env { env_gbl = gbl, env_lcl = lcl }) + = env { env_gbl = gbl', env_lcl = lcl' } + where + !(gbl', lcl') = upd_envs (gbl, lcl) + +restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a +-- See Note [restoreLclEnv vs setLclEnv] +restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl + +{- Note [restoreLclEnv vs setLclEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the typechecker we use this idiom quite a lot + do { (gbl_env, lcl_env) <- tcRnSrcDecls ... + ; setGblEnv gbl_env $ setLclEnv lcl_env $ + more_stuff } + +The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env` +which we then want to be in scope in `more stuff`. + +The problem is that `lcl_env :: TcLclEnv` has an IORef for error +messages `tcl_errs`, and another for constraints (`tcl_lie`),a and +another for Linear Haskell usage information (`tcl_usage`). Now +suppose we change it a tiny bit + do { (gbl_env, lcl_env) <- checkNoErrs $ + tcRnSrcDecls ... + ; setGblEnv gbl_env $ setLclEnv lcl_env $ + more_stuff } + +That should be innocuous. But *alas*, `checkNoErrs` gathers errors in +a fresh IORef *which is then captured in the returned `lcl_env`. When +we do the `setLclEnv` we'll make that captured IORef into the place +where we gather error messages -- but no one is going to look at that!!! +This led to #19470 and #20981. + +Solution: instead of setLclEnv use restoreLclEnv, which preserves from +the /parent/ context these mutable collection IORefs: + tcl_errs, tcl_lie, tcl_usage +-} + -- Command-line flags xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool @@ -1033,9 +1083,9 @@ addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 - = do { errs_var <- getErrsVar ; - msgs0 <- readTcRef errs_var ; - writeTcRef errs_var (unionMessages msgs0 msgs1) } + = do { errs_var <- getErrsVar + ; msgs0 <- readTcRef errs_var + ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) } discardWarnings :: TcRn a -> TcRn a -- Ignore warnings inside the thing inside; @@ -1343,10 +1393,8 @@ -- returned usage information into the larger context appropriately. tcCollectingUsage :: TcM a -> TcM (UsageEnv,a) tcCollectingUsage thing_inside - = do { env0 <- getLclEnv - ; local_usage_ref <- newTcRef zeroUE - ; let env1 = env0 { tcl_usage = local_usage_ref } - ; result <- setLclEnv env1 thing_inside + = do { local_usage_ref <- newTcRef zeroUE + ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside ; local_usage <- readTcRef local_usage_ref ; return (local_usage,result) } @@ -1789,10 +1837,10 @@ -- | The name says it all. The returned TcLevel is the *inner* TcLevel. pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) + = do { tclvl <- getTcLevel + ; let tclvl' = pushTcLevel tclvl ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $ + ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $ captureConstraints thing_inside ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') ; return (tclvl', lie, res) } @@ -1803,20 +1851,10 @@ pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType pushTcLevelM thing_inside - = do { env <- getLclEnv - ; let tclvl' = pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) - thing_inside + = do { tclvl <- getTcLevel + ; let tclvl' = pushTcLevel tclvl + ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside ; return (tclvl', res) } - --- Returns pushed TcLevel -pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel) -pushTcLevelsM num_levels thing_inside - = do { env <- getLclEnv - ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env) - ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $ - thing_inside - ; return (res, tclvl') } getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -3,6 +3,7 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE LambdaCase #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -36,7 +37,7 @@ -------------------------------- -- Creating new evidence variables newEvVar, newEvVars, newDict, - newWanted, newWanteds, cloneWanted, cloneWC, + newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, emitDerivedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, @@ -67,27 +68,29 @@ -------------------------------- -- Zonking and tidying zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins, - tidyEvVar, tidyCt, tidyHole, tidySkolemInfo, + tidyEvVar, tidyCt, tidyHole, zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTyVar, zonkInvisTVBinder, + zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars, + zonkInvisTVBinder, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, zonkTyCoVarsAndFVList, zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, zonkTyCoVarKindBinder, + zonkTyCoVarKind, zonkEvVar, zonkWC, zonkImplication, zonkSimples, zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, + zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon, --------------------------------- -- Promotion, defaulting, skolemisation defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, quantifyTyVars, isQuantifiableTv, - skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar, + zonkAndSkolemise, skolemiseQuantifiedTyVar, doNotQuantifyTyVars, candidateQTyVarsOfType, candidateQTyVarsOfKind, candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + candidateQTyVarsWithBinders, CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, @@ -108,6 +111,7 @@ import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType {- , unifyKind -} ) import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr @@ -126,7 +130,6 @@ import GHC.Builtin.Types import GHC.Types.Error import GHC.Types.Var.Env -import GHC.Types.Name.Env import GHC.Types.Unique.Set import GHC.Types.Basic ( TypeOrKind(..) , NonStandardDefaultingStrategy(..) @@ -186,17 +189,26 @@ newEvVar ty = do { name <- newSysName (predTypeOccName ty) ; return (mkLocalIdOrCoVar name Many ty) } -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty +-- | Create a new Wanted constraint with the given 'CtLoc'. +newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence +newWantedWithLoc loc pty + = do d <- if isEqPrimPred pty then HoleDest <$> newCoercionHole pty else EvVarDest <$> newEvVar pty return $ CtWanted { ctev_dest = d , ctev_pred = pty , ctev_nosh = WDeriv - , ctev_loc = loc } + , ctev_loc = loc } +-- | Create a new Wanted constraint with the given 'CtOrigin', and +-- location information taken from the 'TcM' environment. +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +-- Deals with both equality and non-equality predicates +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + newWantedWithLoc loc pty + +-- | Create new Wanted constraints with the given 'CtOrigin', +-- and location information taken from the 'TcM' environment. newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] newWanteds orig = mapM (newWanted orig Nothing) @@ -839,10 +851,10 @@ ; return tyvar } -- makes a new skolem tv -newSkolemTyVar :: Name -> Kind -> TcM TcTyVar -newSkolemTyVar name kind +newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar +newSkolemTyVar skol_info name kind = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv lvl False)) } + ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } newTyVarTyVar :: Name -> Kind -> TcM TcTyVar -- See Note [TyVarTv] @@ -931,7 +943,10 @@ isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) isFilledMetaTyVar_maybe tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv +-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails +-- at the moment (Jan 22) + | isTcTyVar tv + , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv = do { cts <- readTcRef ref ; case cts of Indirect ty -> return (Just ty) @@ -1348,6 +1363,12 @@ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) -- The selected TyVars are returned as a non-deterministic TyVarSet partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred @@ -1357,6 +1378,17 @@ (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs +-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars +-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose +-- of Note [Naughty quantification candidates]. Why? +-- Because we are going to scoped-sort the quantified variables +-- in among the tvs +candidateQTyVarsWithBinders bound_tvs ty + = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) + ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty + ; return (all_tvs `delCandidates` bound_tvs) } + -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind. @@ -1388,12 +1420,6 @@ candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) mempty tys -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - collect_cand_qtvs :: TcType -- original type that we started recurring into; for errors -> Bool -- True <=> consider every fv in Type to be dependent @@ -1476,6 +1502,11 @@ -> return dv -- this variable is from an outer context; skip -- See Note [Use level numbers for quantification] + | case tcTyVarDetails tv of + SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl + _ -> False + -> return dv -- Skip inner skolems; ToDo: explain + | intersectsVarSet bound tv_kind_vars -- the tyvar must not be from an outer context, but we have -- already checked for this. @@ -1692,7 +1723,8 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars :: NonStandardDefaultingStrategy +quantifyTyVars :: SkolemInfo + -> NonStandardDefaultingStrategy -> CandidatesQTvs -- See Note [Dependent type variables] -- Already zonked -> TcM [TcTyVar] @@ -1703,7 +1735,7 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars ns_strat dvs +quantifyTyVars skol_info ns_strat dvs -- short-circuit common case | isEmptyCandidates dvs = do { traceTc "quantifyTyVars has nothing to quantify" empty @@ -1735,12 +1767,14 @@ = return Nothing -- this can happen for a covar that's associated with -- a coercion hole. Test case: typecheck/should_compile/T2494 - | not (isTcTyVar tkv) - = return (Just tkv) -- For associated types in a class with a standalone - -- kind signature, we have the class variables in - -- scope, and they are TyVars not TcTyVars +-- Omit: no TyVars now +-- | not (isTcTyVar tkv) +-- = return (Just tkv) -- For associated types in a class with a standalone +-- -- kind signature, we have the class variables in +-- -- scope, and they are TyVars not TcTyVars + | otherwise - = Just <$> skolemiseQuantifiedTyVar tkv + = Just <$> skolemiseQuantifiedTyVar skol_info tkv isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification -> TcTyVar @@ -1751,25 +1785,25 @@ | otherwise = False -zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar +zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv. -- (Because non-CUSK type declarations use TyVarTvs.) -- Regardless, it may have a kind that has not yet been zonked, -- and may include kind unification variables. -zonkAndSkolemise tyvar +zonkAndSkolemise skol_info tyvar | isTyVarTyVar tyvar -- We want to preserve the binding location of the original TyVarTv. -- This is important for error messages. If we don't do this, then -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar - ; skolemiseQuantifiedTyVar zonked_tyvar } + = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar + ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } | otherwise = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ zonkTyCoVarKind tyvar -skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar +skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables -- we want to freeze them into ordinary type variables -- The meta tyvar is updated to point to the new skolem TyVar. Now any @@ -1781,14 +1815,14 @@ -- This function is called on both kind and type variables, -- but kind variables *only* if PolyKinds is on. -skolemiseQuantifiedTyVar tv +skolemiseQuantifiedTyVar skol_info tv = case tcTyVarDetails tv of SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind) } -- It might be a skolem type variable, -- for example from a user type signature - MetaTv {} -> skolemiseUnboundMetaTyVar tv + MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk @@ -1900,38 +1934,48 @@ where (dep_kvs, nondep_tvs) = candidateVars dvs -skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar +skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land -- We create a skolem TcTyVar, not a regular TyVar -- See Note [Zonking to Skolem] -skolemiseUnboundMetaTyVar tv +-- +-- Its level should be one greater than the ambient level, which will typically +-- be the same as the level on the meta-tyvar. But not invariably; for example +-- f :: (forall a b. SameKind a b) -> Int +-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each +-- have a level-2 kind unification variable, since it might get unified with another +-- of the level-2 skolems e.g. 'k' in this version +-- f :: (forall k (a :: k) b. SameKind a b) -> Int +-- So when we quantify the kind vars at the top level of the signature, the ambient +-- level is 1, but we will quantify over kappa[2]. + +skolemiseUnboundMetaTyVar skol_info tv = assertPpr (isMetaTyVar tv) (ppr tv) $ - do { when debugIsOn (check_empty tv) - ; here <- getSrcSpanM -- Get the location from "here" - -- ie where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv + do { check_empty tv + ; tc_lvl <- getTcLevel -- Get the location and level from "here" + ; here <- getSrcSpanM -- i.e. where we are generalising + ; kind <- zonkTcType (tyVarKind tv) + ; 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 + details = SkolemTv skol_info (pushTcLevel tc_lvl) False + final_tv = mkTcTyVar final_name kind details ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } - where - details = SkolemTv (metaTyVarTcLevel tv) False check_empty tv -- [Sept 04] Check for non-empty. = when debugIsOn $ -- See note [Silly Type Synonym] do { cts <- readMetaTyVar tv ; case cts of Flexi -> return () - Indirect ty -> warnPprTrace True (ppr tv $$ ppr ty) $ + Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ return () } {- Note [Error on unconstrained meta-variables] @@ -2310,10 +2354,6 @@ zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind') } -zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl) -zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv) - ; return $ Bndr (setTyVarKind tv kind') fl } - {- ************************************************************************ * * @@ -2330,7 +2370,7 @@ = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! -- as #7230 showed ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfo info + ; info' <- zonkSkolemInfoAnon info ; wanted' <- zonkWCRec wanted ; return (implic { ic_skols = skols' , ic_given = given' @@ -2413,13 +2453,16 @@ } zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty +zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk + +zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys ; return (InferSkol ntys') } where do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfo skol_info = return skol_info +zonkSkolemInfoAnon skol_info = return skol_info {- %************************************************************************ @@ -2494,17 +2537,20 @@ -- Variant that assumes that any result of zonking is still a TyVar. -- Should be used only on skolems and TyVarTvs -zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTyVar tv +zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar] +zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar + +zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar +zonkTcTyVarToTcTyVar tv = do { ty <- zonkTcTyVar tv ; let tv' = case tcGetTyVar_maybe ty of Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTyVar" + Nothing -> pprPanic "zonkTcTyVarToTcTyVar" (ppr tv $$ ppr ty) ; return tv' } -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec) -zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv +zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv ; return (Bndr tv' spec) } -- zonkId is used *during* typechecking just to zonk the Id's type @@ -2554,12 +2600,12 @@ zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, GivenOrigin skol_info2) } zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info) - = do { skol_info1 <- zonkSkolemInfo skol_info - ; let skol_info2 = tidySkolemInfo env skol_info1 + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) @@ -2613,44 +2659,7 @@ tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = updateIdTypeAndMult (tidyType env) var ----------------- -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfo _ info = info -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfo --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy InvisArg w arg res) -- Look under c => t - = ty { ft_mult = tidy_ty env w, - ft_arg = tidyType env arg, - ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - ------------------------------------------------------------------------- {- %************************************************************************ @@ -2691,7 +2700,7 @@ naughtyQuantification orig_ty tv escapees = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked - ; escapees' <- mapM zonkTcTyVarToTyVar $ + ; escapees' <- zonkTcTyVarsToTcTyVars $ nonDetEltsUniqSet escapees -- we'll just be printing, so no harmful non-determinism diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -89,7 +90,7 @@ -- returning an uninstantiated sigma-type matchActualFunTySigma :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> Maybe SDoc -- The thing with type TcSigmaType + -> Maybe TypedThing -- The thing with type TcSigmaType -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and -- types of values args to which function has -- been applied already (reversed) @@ -190,7 +191,7 @@ -- for example in function application matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin - -> Maybe SDoc -- the thing with type TcSigmaType + -> Maybe TypedThing -- the thing with type TcSigmaType -> Arity -> TcSigmaType -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType) @@ -523,7 +524,7 @@ tcWrapResultO orig rn_expr expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty , text "Expected:" <+> ppr res_ty ]) - ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty + ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty ; return (mkHsWrap wrap expr) } tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc @@ -545,7 +546,7 @@ unifyExpectedType rn_expr act_ty exp_ty = case exp_ty of Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty + Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt @@ -566,8 +567,8 @@ --------------- tcSubType :: CtOrigin -> UserTypeCtxt - -> TcSigmaType -- Actual - -> ExpRhoType -- Expected + -> TcSigmaType -- ^ Actual + -> ExpRhoType -- ^ Expected -> TcM HsWrapper -- Checks that 'actual' is more polymorphic than 'expected' tcSubType orig ctxt ty_actual ty_expected @@ -575,11 +576,11 @@ do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } -tcSubTypeNC :: CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> Maybe SDoc -- The expression that has type 'actual' (if known) - -> TcSigmaType -- Actual type - -> ExpRhoType -- Expected type +tcSubTypeNC :: CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> TcSigmaType -- ^ Actual type + -> ExpRhoType -- ^ Expected type -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of @@ -863,12 +864,14 @@ -- tcSkolemiseScoped and tcSkolemise tcSkolemiseScoped ctxt expected_ty thing_inside - = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty - ; let skol_tvs = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs + = do { + ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty + ; let skol_tvs = map snd tv_prs + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) + } ; (ev_binds, res) - <- checkConstraints skol_info skol_tvs given $ + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ tcExtendNameTyVarEnv tv_prs $ thing_inside rho_ty @@ -879,13 +882,15 @@ = do { res <- thing_inside expected_ty ; return (idHsWrapper, res) } | otherwise - = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty + = do { + ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; let skol_tvs = map snd tv_prs - skol_info = SigSkol ctxt expected_ty tv_prs + ; let skol_tvs = map snd tv_prs + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) + } ; (ev_binds, result) - <- checkConstraints skol_info skol_tvs given $ + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ thing_inside rho_ty ; return (wrap <.> mkWpLet ev_binds, result) } @@ -902,7 +907,7 @@ = tcSkolemise ctxt ty $ \rho_ty -> thing_inside (mkCheckExpType rho_ty) -checkConstraints :: SkolemInfo +checkConstraints :: SkolemInfoAnon -> [TcTyVar] -- Skolems -> [EvVar] -- Given -> TcM result @@ -938,33 +943,39 @@ -> TcLevel -> WantedConstraints -> TcM () emitResidualTvConstraint skol_info skol_tvs tclvl wanted | not (isEmptyWC wanted) || - checkTelescopeSkol skol_info + checkTelescopeSkol skol_info_anon = -- checkTelescopeSkol: in this case, /always/ emit this implication -- even if 'wanted' is empty. We need the implication so that we check -- for a bad telescope. See Note [Skolem escape and forall-types] in -- GHC.Tc.Gen.HsType - do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted ; emitImplication implic } | otherwise -- Empty 'wanted', emit nothing = return () + where + skol_info_anon = getSkolemInfo skol_info -buildTvImplication :: SkolemInfo -> [TcTyVar] +buildTvImplication :: SkolemInfoAnon -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM Implication buildTvImplication skol_info skol_tvs tclvl wanted - = do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints -- are solved by filling in coercion holes, not -- by creating a value-level evidence binding ; implic <- newImplication - ; return (implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given_eqs = NoGivenEqs - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info }) } + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given_eqs = NoGivenEqs + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } -implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool + ; checkImplicationInvariants implic' + ; return implic' } + +implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool -- See Note [When to build an implication] implicationNeeded skol_info skol_tvs given | null skol_tvs @@ -984,7 +995,7 @@ | otherwise -- Non-empty skolems or givens = return True -- Definitely need an implication -alwaysBuildImplication :: SkolemInfo -> Bool +alwaysBuildImplication :: SkolemInfoAnon -> Bool -- See Note [When to build an implication] alwaysBuildImplication _ = False @@ -1001,7 +1012,7 @@ alwaysBuildImplication _ = False -} -buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar] +buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> WantedConstraints -> TcM (Bag Implication, TcEvBinds) buildImplicationFor tclvl skol_info skol_tvs given wanted @@ -1026,6 +1037,7 @@ , ic_wanted = wanted , ic_binds = ev_binds_var , ic_info = skol_info } + ; checkImplicationInvariants implic' ; return (unitBag implic', TcEvBinds ev_binds_var) } @@ -1071,7 +1083,7 @@ non-exported generic functions. -} -unifyType :: Maybe SDoc -- ^ If present, the thing that has type ty1 +unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 -> TcTauType -> TcTauType -- ty1, ty2 -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types @@ -1081,7 +1093,7 @@ where origin = TypeEqOrigin { uo_actual = ty1 , uo_expected = ty2 - , uo_thing = ppr <$> thing + , uo_thing = thing , uo_visible = True } unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN @@ -1096,7 +1108,7 @@ , uo_visible = True } -unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN +unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN unifyKind mb_thing ty1 ty2 = uType KindLevel origin ty1 ty2 where @@ -1820,8 +1832,7 @@ -- | Breaks apart a function kind into its pieces. matchExpectedFunKind - :: Outputable fun - => fun -- ^ type, only for errors + :: TypedThing -- ^ type, only for errors -> Arity -- ^ n: number of desired arrows -> TcKind -- ^ fun_ kind -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) @@ -1852,7 +1863,7 @@ ; let new_fun = mkVisFunTysMany arg_kinds res_kind origin = TypeEqOrigin { uo_actual = k , uo_expected = new_fun - , uo_thing = Just (ppr hs_ty) + , uo_thing = Just hs_ty , uo_visible = True } ; uType KindLevel origin k new_fun } diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -4,15 +4,14 @@ import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) -import GHC.Tc.Types.Origin ( CtOrigin ) -import GHC.Utils.Outputable( SDoc ) +import GHC.Tc.Types.Origin ( CtOrigin, TypedThing ) import GHC.Hs.Type ( Mult ) -- This boot file exists only to tie the knot between -- GHC.Tc.Utils.Unify and Inst -unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion +unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -37,7 +37,7 @@ zonkCoToCo, zonkEvBinds, zonkTcEvBinds, zonkTcMethInfoToMethInfoX, - lookupTyVarOcc + lookupTyVarX ) where import GHC.Prelude @@ -920,8 +920,9 @@ ; return (HsProc x new_pat new_body) } -- StaticPointers extension -zonkExpr env (HsStatic fvs expr) - = HsStatic fvs <$> zonkLExpr env expr +zonkExpr env (HsStatic (fvs, ty) expr) + = do new_ty <- zonkTcTypeToTypeX env ty + HsStatic (fvs, new_ty) <$> zonkLExpr env expr zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) = do (env1, new_co_fn) <- zonkCoFn env co_fn @@ -1775,7 +1776,7 @@ T9198 and #19668. So yes, it seems worth it. -} -zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType +zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi , ze_tv_env = tv_env , ze_meta_tv_env = mtv_env_ref }) tv @@ -1790,13 +1791,19 @@ Just ty -> return ty Nothing -> do { mtv_details <- readTcRef ref ; zonk_meta ref mtv_details } } - | otherwise + | otherwise -- This should never really happen; + -- TyVars should not occur in the typechecker = lookup_in_tv_env where lookup_in_tv_env -- Look up in the env just as we do for Ids = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv + -- This can happen for RuntimeUnk variables (which + -- should stay as RuntimeUnk), but I think it should + -- not happen for SkolemTv. + mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv + Just tv' -> return (mkTyVarTy tv') zonk_meta ref Flexi @@ -1813,9 +1820,11 @@ = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) ; return ty } -lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar -lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv - = lookupVarEnv tv_env tv +lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar +lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv + = case lookupVarEnv tv_env tv of + Just tv -> tv + Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type -- Only monadic so we can do tc-tracing @@ -1827,6 +1836,9 @@ | isRuntimeRepTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) ; return liftedRepTy } + | isLevityTy zonked_kind + -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) + ; return liftedDataConTy } | isMultiplicityTy zonked_kind -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) ; return manyDataConTy } diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -56,6 +56,7 @@ import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) import GHC.Tc.Instance.Family +import GHC.Types.Basic ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension ) import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -362,7 +363,7 @@ = case ctxt of DefaultDeclCtxt-> MustBeMonoType PatSigCtxt -> rank0 - RuleSigCtxt _ -> rank1 + RuleSigCtxt {} -> rank1 TySynCtxt _ -> rank0 ExprSigCtxt {} -> rank1 @@ -693,8 +694,14 @@ check_type ve ty@(TyConApp tc tys) | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc = check_syn_tc_app ve ty tc tys + + -- Check for unboxed tuples and unboxed sums: these + -- require the corresponding extension to be enabled. | isUnboxedTupleTyCon tc - = check_ubx_tuple ve ty tys + = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys + | isUnboxedSumTyCon tc + = check_ubx_tuple_or_sum UnboxedSumType ve ty tys + | otherwise = mapM_ (check_arg_type False ve) tys @@ -838,16 +845,17 @@ -} ---------------------------------------- -check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () -check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys - = do { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples - ; checkTcM ub_tuples_allowed (env, TcRnUnboxedTupleTypeFuncArg (tidyType env ty)) +check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM () +check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys + = do { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum + ; checkTcM ub_thing_allowed + (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty)) ; impred <- xoptM LangExt.ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg -- c.f. check_arg_type -- However, args are allowed to be unlifted, or - -- more unboxed tuples, so can't use check_arg_ty + -- more unboxed tuples or sums, so can't use check_arg_ty ; mapM_ (check_type (ve{ve_rank = rank'})) tys } ---------------------------------------- diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -184,7 +184,7 @@ = case nameModule_maybe name of Just mod -> Just $ \occ -> getPprStyle $ \sty -> pprModulePrefix sty mod occ <> ppr occ - Nothing -> warnPprTrace True (ppr name) Nothing + Nothing -> warnPprTrace True "pprTyThing" (ppr name) Nothing -- Nothing is unexpected here; TyThings have External names showWithLoc :: SDoc -> SDoc -> SDoc diff --git a/compiler/MachRegs.h b/compiler/MachRegs.h --- a/compiler/MachRegs.h +++ b/compiler/MachRegs.h @@ -340,140 +340,6 @@ #define MAX_REAL_DOUBLE_REG 6 /* ----------------------------------------------------------------------------- - The Sun SPARC register mapping - - !! IMPORTANT: if you change this register mapping you must also update - compiler/GHC/CmmToAsm/SPARC/Regs.hs. That file handles the - mapping for the NCG. This one only affects via-c code. - - The SPARC register (window) story: Remember, within the Haskell - Threaded World, we essentially ``shut down'' the register-window - mechanism---the window doesn't move at all while in this World. It - *does* move, of course, if we call out to arbitrary~C... - - The %i, %l, and %o registers (8 each) are the input, local, and - output registers visible in one register window. The 8 %g (global) - registers are visible all the time. - - zero: always zero - scratch: volatile across C-fn calls. used by linker. - app: usable by application - system: reserved for system - - alloc: allocated to in the register allocator, intra-closure only - - GHC usage v8 ABI v9 ABI - Global - %g0 zero zero zero - %g1 alloc scratch scrach - %g2 alloc app app - %g3 alloc app app - %g4 alloc app scratch - %g5 system scratch - %g6 system system - %g7 system system - - Output: can be zapped by callee - %o0-o5 alloc caller saves - %o6 C stack ptr - %o7 C ret addr - - Local: maintained by register windowing mechanism - %l0 alloc - %l1 R1 - %l2 R2 - %l3 R3 - %l4 R4 - %l5 R5 - %l6 alloc - %l7 alloc - - Input - %i0 Sp - %i1 Base - %i2 SpLim - %i3 Hp - %i4 alloc - %i5 R6 - %i6 C frame ptr - %i7 C ret addr - - The paired nature of the floating point registers causes complications for - the native code generator. For convenience, we pretend that the first 22 - fp regs %f0 .. %f21 are actually 11 double regs, and the remaining 10 are - float (single) regs. The NCG acts accordingly. That means that the - following FP assignment is rather fragile, and should only be changed - with extreme care. The current scheme is: - - %f0 /%f1 FP return from C - %f2 /%f3 D1 - %f4 /%f5 D2 - %f6 /%f7 ncg double spill tmp #1 - %f8 /%f9 ncg double spill tmp #2 - %f10/%f11 allocatable - %f12/%f13 allocatable - %f14/%f15 allocatable - %f16/%f17 allocatable - %f18/%f19 allocatable - %f20/%f21 allocatable - - %f22 F1 - %f23 F2 - %f24 F3 - %f25 F4 - %f26 ncg single spill tmp #1 - %f27 ncg single spill tmp #2 - %f28 allocatable - %f29 allocatable - %f30 allocatable - %f31 allocatable - - -------------------------------------------------------------------------- */ - -#elif defined(MACHREGS_sparc) - -#define REG(x) __asm__("%" #x) - -#define CALLER_SAVES_USER - -#define CALLER_SAVES_F1 -#define CALLER_SAVES_F2 -#define CALLER_SAVES_F3 -#define CALLER_SAVES_F4 -#define CALLER_SAVES_D1 -#define CALLER_SAVES_D2 - -#define REG_R1 l1 -#define REG_R2 l2 -#define REG_R3 l3 -#define REG_R4 l4 -#define REG_R5 l5 -#define REG_R6 i5 - -#define REG_F1 f22 -#define REG_F2 f23 -#define REG_F3 f24 -#define REG_F4 f25 - -/* for each of the double arg regs, - Dn_2 is the high half. */ - -#define REG_D1 f2 -#define REG_D1_2 f3 - -#define REG_D2 f4 -#define REG_D2_2 f5 - -#define REG_Sp i0 -#define REG_SpLim i2 - -#define REG_Hp i3 - -#define REG_Base i1 - -#define NCG_FirstFloatReg f22 - -/* ----------------------------------------------------------------------------- The ARM EABI register mapping Here we consider ARM mode (i.e. 32bit isns) diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20220103 +version: 0.20220201 license: BSD3 license-file: LICENSE category: Development @@ -82,7 +82,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*, - ghc-lib-parser == 0.20220103, + ghc-lib-parser == 0.20220201, stm build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: @@ -136,6 +136,7 @@ GHC.BaseDir, GHC.Builtin.Names, GHC.Builtin.PrimOps, + GHC.Builtin.PrimOps.Ids, GHC.Builtin.Types, GHC.Builtin.Types.Prim, GHC.Builtin.Uniques, @@ -214,6 +215,7 @@ GHC.Data.Pair, GHC.Data.ShortText, GHC.Data.SizedSeq, + GHC.Data.SmallArray, GHC.Data.Stream, GHC.Data.Strict, GHC.Data.StringBuffer, @@ -308,7 +310,6 @@ GHC.Platform.Reg.Class, GHC.Platform.Regs, GHC.Platform.S390X, - GHC.Platform.SPARC, GHC.Platform.Ways, GHC.Platform.X86, GHC.Platform.X86_64, @@ -323,6 +324,7 @@ GHC.Settings.Config, GHC.Settings.Constants, GHC.Stg.Syntax, + GHC.StgToCmm.Config, GHC.StgToCmm.Types, GHC.SysTools.BaseDir, GHC.SysTools.Terminal, @@ -543,7 +545,6 @@ GHC.CmmToAsm.Reg.Linear.FreeRegs GHC.CmmToAsm.Reg.Linear.JoinToTargets GHC.CmmToAsm.Reg.Linear.PPC - GHC.CmmToAsm.Reg.Linear.SPARC GHC.CmmToAsm.Reg.Linear.StackMap GHC.CmmToAsm.Reg.Linear.State GHC.CmmToAsm.Reg.Linear.Stats @@ -552,24 +553,6 @@ GHC.CmmToAsm.Reg.Liveness GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils - GHC.CmmToAsm.SPARC - GHC.CmmToAsm.SPARC.AddrMode - GHC.CmmToAsm.SPARC.Base - GHC.CmmToAsm.SPARC.CodeGen - GHC.CmmToAsm.SPARC.CodeGen.Amode - GHC.CmmToAsm.SPARC.CodeGen.Base - GHC.CmmToAsm.SPARC.CodeGen.CondCode - GHC.CmmToAsm.SPARC.CodeGen.Expand - GHC.CmmToAsm.SPARC.CodeGen.Gen32 - GHC.CmmToAsm.SPARC.CodeGen.Gen64 - GHC.CmmToAsm.SPARC.CodeGen.Sanity - GHC.CmmToAsm.SPARC.Cond - GHC.CmmToAsm.SPARC.Imm - GHC.CmmToAsm.SPARC.Instr - GHC.CmmToAsm.SPARC.Ppr - GHC.CmmToAsm.SPARC.Regs - GHC.CmmToAsm.SPARC.ShortcutJump - GHC.CmmToAsm.SPARC.Stack GHC.CmmToAsm.Types GHC.CmmToAsm.Utils GHC.CmmToAsm.X86 @@ -623,6 +606,8 @@ GHC.Driver.Config.CmmToAsm GHC.Driver.Config.CmmToLlvm GHC.Driver.Config.Finder + GHC.Driver.Config.HsToCore + GHC.Driver.Config.StgToCmm GHC.Driver.GenerateCgIPEStub GHC.Driver.Main GHC.Driver.Make @@ -735,6 +720,7 @@ GHC.StgToCmm.Monad GHC.StgToCmm.Prim GHC.StgToCmm.Prof + GHC.StgToCmm.Sequel GHC.StgToCmm.Ticky GHC.StgToCmm.Utils GHC.SysTools diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl @@ -167,18 +167,6 @@ primOpCanFail FetchNandByteArrayOp_Int = True primOpCanFail FetchOrByteArrayOp_Int = True primOpCanFail FetchXorByteArrayOp_Int = True -primOpCanFail IndexArrayArrayOp_ByteArray = True -primOpCanFail IndexArrayArrayOp_ArrayArray = True -primOpCanFail ReadArrayArrayOp_ByteArray = True -primOpCanFail ReadArrayArrayOp_MutableByteArray = True -primOpCanFail ReadArrayArrayOp_ArrayArray = True -primOpCanFail ReadArrayArrayOp_MutableArrayArray = True -primOpCanFail WriteArrayArrayOp_ByteArray = True -primOpCanFail WriteArrayArrayOp_MutableByteArray = True -primOpCanFail WriteArrayArrayOp_ArrayArray = True -primOpCanFail WriteArrayArrayOp_MutableArrayArray = True -primOpCanFail CopyArrayArrayOp = True -primOpCanFail CopyMutableArrayArrayOp = True primOpCanFail IndexOffAddrOp_Char = True primOpCanFail IndexOffAddrOp_WideChar = True primOpCanFail IndexOffAddrOp_Int = True diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -480,22 +480,6 @@ | FetchNandByteArrayOp_Int | FetchOrByteArrayOp_Int | FetchXorByteArrayOp_Int - | NewArrayArrayOp - | UnsafeFreezeArrayArrayOp - | SizeofArrayArrayOp - | SizeofMutableArrayArrayOp - | IndexArrayArrayOp_ByteArray - | IndexArrayArrayOp_ArrayArray - | ReadArrayArrayOp_ByteArray - | ReadArrayArrayOp_MutableByteArray - | ReadArrayArrayOp_ArrayArray - | ReadArrayArrayOp_MutableArrayArray - | WriteArrayArrayOp_ByteArray - | WriteArrayArrayOp_MutableByteArray - | WriteArrayArrayOp_ArrayArray - | WriteArrayArrayOp_MutableArrayArray - | CopyArrayArrayOp - | CopyMutableArrayArrayOp | AddrAddOp | AddrSubOp | AddrRemOp @@ -600,7 +584,7 @@ | ReadMVarOp | TryReadMVarOp | IsEmptyMVarOp - | NewIOPortrOp + | NewIOPortOp | ReadIOPortOp | WriteIOPortOp | DelayOp diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -79,7 +79,7 @@ , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("freezeArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("thawArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") - , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a lifted value makes this function harder\n to use correctly than @casIntArray\\#@. All of the difficulties\n of using @reallyUnsafePtrEquality\\#@ correctly apply to\n @casArray\\#@ as well.\n ") + , ("casArray#","Given an array, an offset, the expected old value, and\n the new value, perform an atomic compare and swap (i.e. write the new\n value if the current value and the old value are the same pointer).\n Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n the element at the offset after the operation completes. This means that\n on a success the new value is returned, and on a failure the actual old\n value (not the expected one) is returned. Implies a full memory barrier.\n The use of a pointer equality on a boxed value makes this function harder\n to use correctly than @casIntArray\\#@. All of the difficulties\n of using @reallyUnsafePtrEquality\\#@ correctly apply to\n @casArray\\#@ as well.\n ") , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n in the specified state thread,\n with each element containing the specified initial value.") , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n the specified state thread. The new size argument must be less than or\n equal to the current size as reported by @getSizeofSmallMutableArray\\#@.") , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.") @@ -220,12 +220,6 @@ , ("fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n atomically NAND the value into the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") , ("fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n atomically OR the value into the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n atomically XOR the value into the element. Returns the value of the\n element before the operation. Implies a full memory barrier.") - , ("newArrayArray#","Create a new mutable array of arrays with the specified number of elements,\n in the specified state thread, with each element recursively referring to the\n newly created array.") - , ("unsafeFreezeArrayArray#","Make a mutable array of arrays immutable, without copying.") - , ("sizeofArrayArray#","Return the number of elements in the array.") - , ("sizeofMutableArrayArray#","Return the number of elements in the array.") - , ("copyArrayArray#","Copy a range of the ArrayArray\\# to the specified region in the MutableArrayArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked.\n The two arrays must not be the same array in different states, but this is not checked either.") - , ("copyMutableArrayArray#","Copy a range of the first MutableArrayArray# to the specified region in the second\n MutableArrayArray#.\n Both arrays must fully contain the specified ranges, but this is not checked.\n The regions are allowed to overlap, although this is only possible when the same\n array is provided as both the source and the destination.\n ") , ("Addr#"," An arbitrary machine address assumed to point outside\n the garbage-collected heap. ") , ("nullAddr#"," The null address. ") , ("minusAddr#","Result is meaningless if two @Addr\\#@s are so far apart that their\n difference doesn't fit in an @Int\\#@.") @@ -258,9 +252,10 @@ , ("writeMutVar#","Write contents of @MutVar\\#@.") , ("atomicModifyMutVar2#"," Modify the contents of a @MutVar\\#@, returning the previous\n contents and the result of applying the given function to the\n previous contents. Note that this isn't strictly\n speaking the correct type for this function; it should really be\n @MutVar\\# s a -> (a -> (a,b)) -> State\\# s -> (\\# State\\# s, a, (a, b) \\#)@,\n but we don't know about pairs here. ") , ("atomicModifyMutVar_#"," Modify the contents of a @MutVar\\#@, returning the previous\n contents and the result of applying the given function to the\n previous contents. ") + , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n the first value passed to this function and the value\n stored inside the @MutVar\\#@. If the pointers are equal,\n replace the stored value with the second value passed to this\n function, otherwise do nothing.\n Returns the final value stored inside the @MutVar\\#@.\n The @Int\\#@ indicates whether a swap took place,\n with @1\\#@ meaning that we didn't swap, and @0\\#@\n that we did.\n Implies a full memory barrier.\n Because the comparison is done on the level of pointers,\n all of the difficulties of using\n @reallyUnsafePtrEquality\\#@ correctly apply to\n @casMutVar\\#@ as well.\n ") , ("newTVar#","Create a new @TVar\\#@ holding a specified initial value.") - , ("readTVar#","Read contents of @TVar\\#@. Result is not yet evaluated.") - , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction") + , ("readTVar#","Read contents of @TVar\\#@ inside an STM transaction,\n i.e. within a call to @atomically\\#@.\n Does not force evaluation of the result.") + , ("readTVarIO#","Read contents of @TVar\\#@ outside an STM transaction.\n Does not force evaluation of the result.") , ("writeTVar#","Write contents of @TVar\\#@.") , ("MVar#"," A shared mutable variable (/not/ the same as a @MutVar\\#@!).\n (Note: in a non-concurrent implementation, @(MVar\\# a)@ can be\n represented by @(MutVar\\# (Maybe a))@.) ") , ("newMVar#","Create new @MVar\\#@; initially empty.") @@ -273,8 +268,8 @@ , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.") , ("IOPort#"," A shared I/O port is almost the same as a @MVar\\#@!).\n The main difference is that IOPort has no deadlock detection or\n deadlock breaking code that forcibly releases the lock. ") , ("newIOPort#","Create new @IOPort\\#@; initially empty.") - , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.") - , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0.\n Otherwise, store value arg as @IOPort\\#@'s new contents,\n and return with integer 1. ") + , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n Then remove and return its contents, and set it empty.\n Throws an @IOPortException@ if another thread is already\n waiting to read this @IOPort\\#@.") + , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0,\n throwing an @IOPortException@.\n Otherwise, store value arg as @IOPort\\#@'s new contents,\n and return with integer 1. ") , ("delay#","Sleep specified number of microseconds.") , ("waitRead#","Block until input is available on specified file descriptor.") , ("waitWrite#","Block until output is possible on specified file descriptor.") diff --git a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl @@ -108,18 +108,6 @@ primOpHasSideEffects FetchNandByteArrayOp_Int = True primOpHasSideEffects FetchOrByteArrayOp_Int = True primOpHasSideEffects FetchXorByteArrayOp_Int = True -primOpHasSideEffects NewArrayArrayOp = True -primOpHasSideEffects UnsafeFreezeArrayArrayOp = True -primOpHasSideEffects ReadArrayArrayOp_ByteArray = True -primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True -primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True -primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True -primOpHasSideEffects WriteArrayArrayOp_ByteArray = True -primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True -primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True -primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True -primOpHasSideEffects CopyArrayArrayOp = True -primOpHasSideEffects CopyMutableArrayArrayOp = True primOpHasSideEffects ReadOffAddrOp_Char = True primOpHasSideEffects ReadOffAddrOp_WideChar = True primOpHasSideEffects ReadOffAddrOp_Int = True @@ -196,7 +184,7 @@ primOpHasSideEffects ReadMVarOp = True primOpHasSideEffects TryReadMVarOp = True primOpHasSideEffects IsEmptyMVarOp = True -primOpHasSideEffects NewIOPortrOp = True +primOpHasSideEffects NewIOPortOp = True primOpHasSideEffects ReadIOPortOp = True primOpHasSideEffects WriteIOPortOp = True primOpHasSideEffects DelayOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -479,22 +479,6 @@ , FetchNandByteArrayOp_Int , FetchOrByteArrayOp_Int , FetchXorByteArrayOp_Int - , NewArrayArrayOp - , UnsafeFreezeArrayArrayOp - , SizeofArrayArrayOp - , SizeofMutableArrayArrayOp - , IndexArrayArrayOp_ByteArray - , IndexArrayArrayOp_ArrayArray - , ReadArrayArrayOp_ByteArray - , ReadArrayArrayOp_MutableByteArray - , ReadArrayArrayOp_ArrayArray - , ReadArrayArrayOp_MutableArrayArray - , WriteArrayArrayOp_ByteArray - , WriteArrayArrayOp_MutableByteArray - , WriteArrayArrayOp_ArrayArray - , WriteArrayArrayOp_MutableArrayArray - , CopyArrayArrayOp - , CopyMutableArrayArrayOp , AddrAddOp , AddrSubOp , AddrRemOp @@ -599,7 +583,7 @@ , ReadMVarOp , TryReadMVarOp , IsEmptyMVarOp - , NewIOPortrOp + , NewIOPortOp , ReadIOPortOp , WriteIOPortOp , DelayOp diff --git a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl @@ -27,9 +27,6 @@ primOpOutOfLine ByteArrayIsPinnedOp = True primOpOutOfLine ShrinkMutableByteArrayOp_Char = True primOpOutOfLine ResizeMutableByteArrayOp_Char = True -primOpOutOfLine NewArrayArrayOp = True -primOpOutOfLine CopyArrayArrayOp = True -primOpOutOfLine CopyMutableArrayArrayOp = True primOpOutOfLine NewMutVarOp = True primOpOutOfLine AtomicModifyMutVar2Op = True primOpOutOfLine AtomicModifyMutVar_Op = True @@ -57,7 +54,7 @@ primOpOutOfLine ReadMVarOp = True primOpOutOfLine TryReadMVarOp = True primOpOutOfLine IsEmptyMVarOp = True -primOpOutOfLine NewIOPortrOp = True +primOpOutOfLine NewIOPortOp = True primOpOutOfLine ReadIOPortOp = True primOpOutOfLine WriteIOPortOp = True primOpOutOfLine DelayOp = True diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -324,38 +324,38 @@ primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) -primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVarSpec, deltaTyVarSpec] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) -primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) -primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy] (intPrimTy) -primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) -primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy])) -primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) -primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) -primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) -primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVarSpec, alphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy] (intPrimTy) +primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy) +primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) +primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy])) +primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy levPolyAlphaTy) +primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy])) +primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) +primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy] (intPrimTy) +primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy) +primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) +primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy])) +primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy levPolyAlphaTy) +primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy])) +primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy])) +primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVarSpec] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) @@ -479,22 +479,6 @@ primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) -primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) -primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) -primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) -primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) -primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) -primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) -primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVarSpec] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVarSpec] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) @@ -570,43 +554,43 @@ primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#") [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#") [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) -primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy levPolyAlphaTy])) +primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#") [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy])) primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy])) -primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [alphaTyVarSpec, runtimeRep2TyVarInf, openBetaTyVarSpec] [alphaTy] (openBetaTy) -primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVarSpec, betaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])) -primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) +primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [runtimeRep1TyVarInf, openAlphaTyVarSpec, levity2TyVarInf, levPolyBetaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), (mkVisFunTyMany (levPolyBetaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) +primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [levity1TyVarInf, levPolyAlphaTyVarSpec, runtimeRep2TyVarInf, openBetaTyVarSpec] [levPolyAlphaTy] (openBetaTy) +primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [levity1TyVarInf, levPolyAlphaTyVarSpec, runtimeRep2TyVarInf, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy])) +primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) +primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) +primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy])) primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) -primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) -primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) -primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVarSpec, alphaTyVarSpec] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) -primOpInfo NewIOPortrOp = mkGenPrimOp (fsLit "newIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy alphaTy])) -primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkIOPortPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) -primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#") [deltaTyVarSpec, alphaTyVarSpec] [mkIOPortPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) +primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) +primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) +primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) +primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy levPolyAlphaTy])) +primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy levPolyAlphaTy])) +primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) +primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy])) +primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo NewIOPortOp = mkGenPrimOp (fsLit "newIOPort#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy levPolyAlphaTy])) +primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy])) +primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#") [deltaTyVarSpec, levity1TyVarInf, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) -primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) -primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVarSpec] [intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [runtimeRep1TyVarInf, openAlphaTyVarSpec] [intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVarSpec] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy])) @@ -614,17 +598,17 @@ primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [deltaTyVarSpec] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) -primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, betaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [levPolyAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) -primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) -primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVarSpec] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) -primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) +primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec, levity2TyVarInf, levPolyBetaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy])) +primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [levity1TyVarInf, levPolyAlphaTyVarSpec, levity2TyVarInf, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy])) +primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, levPolyAlphaTy])) +primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))])) primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) -primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) -primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVarSpec] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])) -primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVarSpec] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) -primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) -primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVarSpec] [mkStableNamePrimTy alphaTy] (intPrimTy) +primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy levPolyAlphaTy])) +primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy])) +primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStablePtrPrimTy levPolyAlphaTy] (intPrimTy) +primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy levPolyAlphaTy])) +primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStableNamePrimTy levPolyAlphaTy] (intPrimTy) primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#") [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy])) primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#") [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#") [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -1,1323 +1,1307 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1320 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 1 -primOpTag CharGeOp = 2 -primOpTag CharEqOp = 3 -primOpTag CharNeOp = 4 -primOpTag CharLtOp = 5 -primOpTag CharLeOp = 6 -primOpTag OrdOp = 7 -primOpTag Int8ToIntOp = 8 -primOpTag IntToInt8Op = 9 -primOpTag Int8NegOp = 10 -primOpTag Int8AddOp = 11 -primOpTag Int8SubOp = 12 -primOpTag Int8MulOp = 13 -primOpTag Int8QuotOp = 14 -primOpTag Int8RemOp = 15 -primOpTag Int8QuotRemOp = 16 -primOpTag Int8SllOp = 17 -primOpTag Int8SraOp = 18 -primOpTag Int8SrlOp = 19 -primOpTag Int8ToWord8Op = 20 -primOpTag Int8EqOp = 21 -primOpTag Int8GeOp = 22 -primOpTag Int8GtOp = 23 -primOpTag Int8LeOp = 24 -primOpTag Int8LtOp = 25 -primOpTag Int8NeOp = 26 -primOpTag Word8ToWordOp = 27 -primOpTag WordToWord8Op = 28 -primOpTag Word8AddOp = 29 -primOpTag Word8SubOp = 30 -primOpTag Word8MulOp = 31 -primOpTag Word8QuotOp = 32 -primOpTag Word8RemOp = 33 -primOpTag Word8QuotRemOp = 34 -primOpTag Word8AndOp = 35 -primOpTag Word8OrOp = 36 -primOpTag Word8XorOp = 37 -primOpTag Word8NotOp = 38 -primOpTag Word8SllOp = 39 -primOpTag Word8SrlOp = 40 -primOpTag Word8ToInt8Op = 41 -primOpTag Word8EqOp = 42 -primOpTag Word8GeOp = 43 -primOpTag Word8GtOp = 44 -primOpTag Word8LeOp = 45 -primOpTag Word8LtOp = 46 -primOpTag Word8NeOp = 47 -primOpTag Int16ToIntOp = 48 -primOpTag IntToInt16Op = 49 -primOpTag Int16NegOp = 50 -primOpTag Int16AddOp = 51 -primOpTag Int16SubOp = 52 -primOpTag Int16MulOp = 53 -primOpTag Int16QuotOp = 54 -primOpTag Int16RemOp = 55 -primOpTag Int16QuotRemOp = 56 -primOpTag Int16SllOp = 57 -primOpTag Int16SraOp = 58 -primOpTag Int16SrlOp = 59 -primOpTag Int16ToWord16Op = 60 -primOpTag Int16EqOp = 61 -primOpTag Int16GeOp = 62 -primOpTag Int16GtOp = 63 -primOpTag Int16LeOp = 64 -primOpTag Int16LtOp = 65 -primOpTag Int16NeOp = 66 -primOpTag Word16ToWordOp = 67 -primOpTag WordToWord16Op = 68 -primOpTag Word16AddOp = 69 -primOpTag Word16SubOp = 70 -primOpTag Word16MulOp = 71 -primOpTag Word16QuotOp = 72 -primOpTag Word16RemOp = 73 -primOpTag Word16QuotRemOp = 74 -primOpTag Word16AndOp = 75 -primOpTag Word16OrOp = 76 -primOpTag Word16XorOp = 77 -primOpTag Word16NotOp = 78 -primOpTag Word16SllOp = 79 -primOpTag Word16SrlOp = 80 -primOpTag Word16ToInt16Op = 81 -primOpTag Word16EqOp = 82 -primOpTag Word16GeOp = 83 -primOpTag Word16GtOp = 84 -primOpTag Word16LeOp = 85 -primOpTag Word16LtOp = 86 -primOpTag Word16NeOp = 87 -primOpTag Int32ToIntOp = 88 -primOpTag IntToInt32Op = 89 -primOpTag Int32NegOp = 90 -primOpTag Int32AddOp = 91 -primOpTag Int32SubOp = 92 -primOpTag Int32MulOp = 93 -primOpTag Int32QuotOp = 94 -primOpTag Int32RemOp = 95 -primOpTag Int32QuotRemOp = 96 -primOpTag Int32SllOp = 97 -primOpTag Int32SraOp = 98 -primOpTag Int32SrlOp = 99 -primOpTag Int32ToWord32Op = 100 -primOpTag Int32EqOp = 101 -primOpTag Int32GeOp = 102 -primOpTag Int32GtOp = 103 -primOpTag Int32LeOp = 104 -primOpTag Int32LtOp = 105 -primOpTag Int32NeOp = 106 -primOpTag Word32ToWordOp = 107 -primOpTag WordToWord32Op = 108 -primOpTag Word32AddOp = 109 -primOpTag Word32SubOp = 110 -primOpTag Word32MulOp = 111 -primOpTag Word32QuotOp = 112 -primOpTag Word32RemOp = 113 -primOpTag Word32QuotRemOp = 114 -primOpTag Word32AndOp = 115 -primOpTag Word32OrOp = 116 -primOpTag Word32XorOp = 117 -primOpTag Word32NotOp = 118 -primOpTag Word32SllOp = 119 -primOpTag Word32SrlOp = 120 -primOpTag Word32ToInt32Op = 121 -primOpTag Word32EqOp = 122 -primOpTag Word32GeOp = 123 -primOpTag Word32GtOp = 124 -primOpTag Word32LeOp = 125 -primOpTag Word32LtOp = 126 -primOpTag Word32NeOp = 127 -primOpTag Int64ToIntOp = 128 -primOpTag IntToInt64Op = 129 -primOpTag Int64NegOp = 130 -primOpTag Int64AddOp = 131 -primOpTag Int64SubOp = 132 -primOpTag Int64MulOp = 133 -primOpTag Int64QuotOp = 134 -primOpTag Int64RemOp = 135 -primOpTag Int64SllOp = 136 -primOpTag Int64SraOp = 137 -primOpTag Int64SrlOp = 138 -primOpTag Int64ToWord64Op = 139 -primOpTag Int64EqOp = 140 -primOpTag Int64GeOp = 141 -primOpTag Int64GtOp = 142 -primOpTag Int64LeOp = 143 -primOpTag Int64LtOp = 144 -primOpTag Int64NeOp = 145 -primOpTag Word64ToWordOp = 146 -primOpTag WordToWord64Op = 147 -primOpTag Word64AddOp = 148 -primOpTag Word64SubOp = 149 -primOpTag Word64MulOp = 150 -primOpTag Word64QuotOp = 151 -primOpTag Word64RemOp = 152 -primOpTag Word64AndOp = 153 -primOpTag Word64OrOp = 154 -primOpTag Word64XorOp = 155 -primOpTag Word64NotOp = 156 -primOpTag Word64SllOp = 157 -primOpTag Word64SrlOp = 158 -primOpTag Word64ToInt64Op = 159 -primOpTag Word64EqOp = 160 -primOpTag Word64GeOp = 161 -primOpTag Word64GtOp = 162 -primOpTag Word64LeOp = 163 -primOpTag Word64LtOp = 164 -primOpTag Word64NeOp = 165 -primOpTag IntAddOp = 166 -primOpTag IntSubOp = 167 -primOpTag IntMulOp = 168 -primOpTag IntMul2Op = 169 -primOpTag IntMulMayOfloOp = 170 -primOpTag IntQuotOp = 171 -primOpTag IntRemOp = 172 -primOpTag IntQuotRemOp = 173 -primOpTag IntAndOp = 174 -primOpTag IntOrOp = 175 -primOpTag IntXorOp = 176 -primOpTag IntNotOp = 177 -primOpTag IntNegOp = 178 -primOpTag IntAddCOp = 179 -primOpTag IntSubCOp = 180 -primOpTag IntGtOp = 181 -primOpTag IntGeOp = 182 -primOpTag IntEqOp = 183 -primOpTag IntNeOp = 184 -primOpTag IntLtOp = 185 -primOpTag IntLeOp = 186 -primOpTag ChrOp = 187 -primOpTag IntToWordOp = 188 -primOpTag IntToFloatOp = 189 -primOpTag IntToDoubleOp = 190 -primOpTag WordToFloatOp = 191 -primOpTag WordToDoubleOp = 192 -primOpTag IntSllOp = 193 -primOpTag IntSraOp = 194 -primOpTag IntSrlOp = 195 -primOpTag WordAddOp = 196 -primOpTag WordAddCOp = 197 -primOpTag WordSubCOp = 198 -primOpTag WordAdd2Op = 199 -primOpTag WordSubOp = 200 -primOpTag WordMulOp = 201 -primOpTag WordMul2Op = 202 -primOpTag WordQuotOp = 203 -primOpTag WordRemOp = 204 -primOpTag WordQuotRemOp = 205 -primOpTag WordQuotRem2Op = 206 -primOpTag WordAndOp = 207 -primOpTag WordOrOp = 208 -primOpTag WordXorOp = 209 -primOpTag WordNotOp = 210 -primOpTag WordSllOp = 211 -primOpTag WordSrlOp = 212 -primOpTag WordToIntOp = 213 -primOpTag WordGtOp = 214 -primOpTag WordGeOp = 215 -primOpTag WordEqOp = 216 -primOpTag WordNeOp = 217 -primOpTag WordLtOp = 218 -primOpTag WordLeOp = 219 -primOpTag PopCnt8Op = 220 -primOpTag PopCnt16Op = 221 -primOpTag PopCnt32Op = 222 -primOpTag PopCnt64Op = 223 -primOpTag PopCntOp = 224 -primOpTag Pdep8Op = 225 -primOpTag Pdep16Op = 226 -primOpTag Pdep32Op = 227 -primOpTag Pdep64Op = 228 -primOpTag PdepOp = 229 -primOpTag Pext8Op = 230 -primOpTag Pext16Op = 231 -primOpTag Pext32Op = 232 -primOpTag Pext64Op = 233 -primOpTag PextOp = 234 -primOpTag Clz8Op = 235 -primOpTag Clz16Op = 236 -primOpTag Clz32Op = 237 -primOpTag Clz64Op = 238 -primOpTag ClzOp = 239 -primOpTag Ctz8Op = 240 -primOpTag Ctz16Op = 241 -primOpTag Ctz32Op = 242 -primOpTag Ctz64Op = 243 -primOpTag CtzOp = 244 -primOpTag BSwap16Op = 245 -primOpTag BSwap32Op = 246 -primOpTag BSwap64Op = 247 -primOpTag BSwapOp = 248 -primOpTag BRev8Op = 249 -primOpTag BRev16Op = 250 -primOpTag BRev32Op = 251 -primOpTag BRev64Op = 252 -primOpTag BRevOp = 253 -primOpTag Narrow8IntOp = 254 -primOpTag Narrow16IntOp = 255 -primOpTag Narrow32IntOp = 256 -primOpTag Narrow8WordOp = 257 -primOpTag Narrow16WordOp = 258 -primOpTag Narrow32WordOp = 259 -primOpTag DoubleGtOp = 260 -primOpTag DoubleGeOp = 261 -primOpTag DoubleEqOp = 262 -primOpTag DoubleNeOp = 263 -primOpTag DoubleLtOp = 264 -primOpTag DoubleLeOp = 265 -primOpTag DoubleAddOp = 266 -primOpTag DoubleSubOp = 267 -primOpTag DoubleMulOp = 268 -primOpTag DoubleDivOp = 269 -primOpTag DoubleNegOp = 270 -primOpTag DoubleFabsOp = 271 -primOpTag DoubleToIntOp = 272 -primOpTag DoubleToFloatOp = 273 -primOpTag DoubleExpOp = 274 -primOpTag DoubleExpM1Op = 275 -primOpTag DoubleLogOp = 276 -primOpTag DoubleLog1POp = 277 -primOpTag DoubleSqrtOp = 278 -primOpTag DoubleSinOp = 279 -primOpTag DoubleCosOp = 280 -primOpTag DoubleTanOp = 281 -primOpTag DoubleAsinOp = 282 -primOpTag DoubleAcosOp = 283 -primOpTag DoubleAtanOp = 284 -primOpTag DoubleSinhOp = 285 -primOpTag DoubleCoshOp = 286 -primOpTag DoubleTanhOp = 287 -primOpTag DoubleAsinhOp = 288 -primOpTag DoubleAcoshOp = 289 -primOpTag DoubleAtanhOp = 290 -primOpTag DoublePowerOp = 291 -primOpTag DoubleDecode_2IntOp = 292 -primOpTag DoubleDecode_Int64Op = 293 -primOpTag FloatGtOp = 294 -primOpTag FloatGeOp = 295 -primOpTag FloatEqOp = 296 -primOpTag FloatNeOp = 297 -primOpTag FloatLtOp = 298 -primOpTag FloatLeOp = 299 -primOpTag FloatAddOp = 300 -primOpTag FloatSubOp = 301 -primOpTag FloatMulOp = 302 -primOpTag FloatDivOp = 303 -primOpTag FloatNegOp = 304 -primOpTag FloatFabsOp = 305 -primOpTag FloatToIntOp = 306 -primOpTag FloatExpOp = 307 -primOpTag FloatExpM1Op = 308 -primOpTag FloatLogOp = 309 -primOpTag FloatLog1POp = 310 -primOpTag FloatSqrtOp = 311 -primOpTag FloatSinOp = 312 -primOpTag FloatCosOp = 313 -primOpTag FloatTanOp = 314 -primOpTag FloatAsinOp = 315 -primOpTag FloatAcosOp = 316 -primOpTag FloatAtanOp = 317 -primOpTag FloatSinhOp = 318 -primOpTag FloatCoshOp = 319 -primOpTag FloatTanhOp = 320 -primOpTag FloatAsinhOp = 321 -primOpTag FloatAcoshOp = 322 -primOpTag FloatAtanhOp = 323 -primOpTag FloatPowerOp = 324 -primOpTag FloatToDoubleOp = 325 -primOpTag FloatDecode_IntOp = 326 -primOpTag NewArrayOp = 327 -primOpTag ReadArrayOp = 328 -primOpTag WriteArrayOp = 329 -primOpTag SizeofArrayOp = 330 -primOpTag SizeofMutableArrayOp = 331 -primOpTag IndexArrayOp = 332 -primOpTag UnsafeFreezeArrayOp = 333 -primOpTag UnsafeThawArrayOp = 334 -primOpTag CopyArrayOp = 335 -primOpTag CopyMutableArrayOp = 336 -primOpTag CloneArrayOp = 337 -primOpTag CloneMutableArrayOp = 338 -primOpTag FreezeArrayOp = 339 -primOpTag ThawArrayOp = 340 -primOpTag CasArrayOp = 341 -primOpTag NewSmallArrayOp = 342 -primOpTag ShrinkSmallMutableArrayOp_Char = 343 -primOpTag ReadSmallArrayOp = 344 -primOpTag WriteSmallArrayOp = 345 -primOpTag SizeofSmallArrayOp = 346 -primOpTag SizeofSmallMutableArrayOp = 347 -primOpTag GetSizeofSmallMutableArrayOp = 348 -primOpTag IndexSmallArrayOp = 349 -primOpTag UnsafeFreezeSmallArrayOp = 350 -primOpTag UnsafeThawSmallArrayOp = 351 -primOpTag CopySmallArrayOp = 352 -primOpTag CopySmallMutableArrayOp = 353 -primOpTag CloneSmallArrayOp = 354 -primOpTag CloneSmallMutableArrayOp = 355 -primOpTag FreezeSmallArrayOp = 356 -primOpTag ThawSmallArrayOp = 357 -primOpTag CasSmallArrayOp = 358 -primOpTag NewByteArrayOp_Char = 359 -primOpTag NewPinnedByteArrayOp_Char = 360 -primOpTag NewAlignedPinnedByteArrayOp_Char = 361 -primOpTag MutableByteArrayIsPinnedOp = 362 -primOpTag ByteArrayIsPinnedOp = 363 -primOpTag ByteArrayContents_Char = 364 -primOpTag MutableByteArrayContents_Char = 365 -primOpTag ShrinkMutableByteArrayOp_Char = 366 -primOpTag ResizeMutableByteArrayOp_Char = 367 -primOpTag UnsafeFreezeByteArrayOp = 368 -primOpTag SizeofByteArrayOp = 369 -primOpTag SizeofMutableByteArrayOp = 370 -primOpTag GetSizeofMutableByteArrayOp = 371 -primOpTag IndexByteArrayOp_Char = 372 -primOpTag IndexByteArrayOp_WideChar = 373 -primOpTag IndexByteArrayOp_Int = 374 -primOpTag IndexByteArrayOp_Word = 375 -primOpTag IndexByteArrayOp_Addr = 376 -primOpTag IndexByteArrayOp_Float = 377 -primOpTag IndexByteArrayOp_Double = 378 -primOpTag IndexByteArrayOp_StablePtr = 379 -primOpTag IndexByteArrayOp_Int8 = 380 -primOpTag IndexByteArrayOp_Int16 = 381 -primOpTag IndexByteArrayOp_Int32 = 382 -primOpTag IndexByteArrayOp_Int64 = 383 -primOpTag IndexByteArrayOp_Word8 = 384 -primOpTag IndexByteArrayOp_Word16 = 385 -primOpTag IndexByteArrayOp_Word32 = 386 -primOpTag IndexByteArrayOp_Word64 = 387 -primOpTag IndexByteArrayOp_Word8AsChar = 388 -primOpTag IndexByteArrayOp_Word8AsWideChar = 389 -primOpTag IndexByteArrayOp_Word8AsInt = 390 -primOpTag IndexByteArrayOp_Word8AsWord = 391 -primOpTag IndexByteArrayOp_Word8AsAddr = 392 -primOpTag IndexByteArrayOp_Word8AsFloat = 393 -primOpTag IndexByteArrayOp_Word8AsDouble = 394 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 395 -primOpTag IndexByteArrayOp_Word8AsInt16 = 396 -primOpTag IndexByteArrayOp_Word8AsInt32 = 397 -primOpTag IndexByteArrayOp_Word8AsInt64 = 398 -primOpTag IndexByteArrayOp_Word8AsWord16 = 399 -primOpTag IndexByteArrayOp_Word8AsWord32 = 400 -primOpTag IndexByteArrayOp_Word8AsWord64 = 401 -primOpTag ReadByteArrayOp_Char = 402 -primOpTag ReadByteArrayOp_WideChar = 403 -primOpTag ReadByteArrayOp_Int = 404 -primOpTag ReadByteArrayOp_Word = 405 -primOpTag ReadByteArrayOp_Addr = 406 -primOpTag ReadByteArrayOp_Float = 407 -primOpTag ReadByteArrayOp_Double = 408 -primOpTag ReadByteArrayOp_StablePtr = 409 -primOpTag ReadByteArrayOp_Int8 = 410 -primOpTag ReadByteArrayOp_Int16 = 411 -primOpTag ReadByteArrayOp_Int32 = 412 -primOpTag ReadByteArrayOp_Int64 = 413 -primOpTag ReadByteArrayOp_Word8 = 414 -primOpTag ReadByteArrayOp_Word16 = 415 -primOpTag ReadByteArrayOp_Word32 = 416 -primOpTag ReadByteArrayOp_Word64 = 417 -primOpTag ReadByteArrayOp_Word8AsChar = 418 -primOpTag ReadByteArrayOp_Word8AsWideChar = 419 -primOpTag ReadByteArrayOp_Word8AsInt = 420 -primOpTag ReadByteArrayOp_Word8AsWord = 421 -primOpTag ReadByteArrayOp_Word8AsAddr = 422 -primOpTag ReadByteArrayOp_Word8AsFloat = 423 -primOpTag ReadByteArrayOp_Word8AsDouble = 424 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 425 -primOpTag ReadByteArrayOp_Word8AsInt16 = 426 -primOpTag ReadByteArrayOp_Word8AsInt32 = 427 -primOpTag ReadByteArrayOp_Word8AsInt64 = 428 -primOpTag ReadByteArrayOp_Word8AsWord16 = 429 -primOpTag ReadByteArrayOp_Word8AsWord32 = 430 -primOpTag ReadByteArrayOp_Word8AsWord64 = 431 -primOpTag WriteByteArrayOp_Char = 432 -primOpTag WriteByteArrayOp_WideChar = 433 -primOpTag WriteByteArrayOp_Int = 434 -primOpTag WriteByteArrayOp_Word = 435 -primOpTag WriteByteArrayOp_Addr = 436 -primOpTag WriteByteArrayOp_Float = 437 -primOpTag WriteByteArrayOp_Double = 438 -primOpTag WriteByteArrayOp_StablePtr = 439 -primOpTag WriteByteArrayOp_Int8 = 440 -primOpTag WriteByteArrayOp_Int16 = 441 -primOpTag WriteByteArrayOp_Int32 = 442 -primOpTag WriteByteArrayOp_Int64 = 443 -primOpTag WriteByteArrayOp_Word8 = 444 -primOpTag WriteByteArrayOp_Word16 = 445 -primOpTag WriteByteArrayOp_Word32 = 446 -primOpTag WriteByteArrayOp_Word64 = 447 -primOpTag WriteByteArrayOp_Word8AsChar = 448 -primOpTag WriteByteArrayOp_Word8AsWideChar = 449 -primOpTag WriteByteArrayOp_Word8AsInt = 450 -primOpTag WriteByteArrayOp_Word8AsWord = 451 -primOpTag WriteByteArrayOp_Word8AsAddr = 452 -primOpTag WriteByteArrayOp_Word8AsFloat = 453 -primOpTag WriteByteArrayOp_Word8AsDouble = 454 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 455 -primOpTag WriteByteArrayOp_Word8AsInt16 = 456 -primOpTag WriteByteArrayOp_Word8AsInt32 = 457 -primOpTag WriteByteArrayOp_Word8AsInt64 = 458 -primOpTag WriteByteArrayOp_Word8AsWord16 = 459 -primOpTag WriteByteArrayOp_Word8AsWord32 = 460 -primOpTag WriteByteArrayOp_Word8AsWord64 = 461 -primOpTag CompareByteArraysOp = 462 -primOpTag CopyByteArrayOp = 463 -primOpTag CopyMutableByteArrayOp = 464 -primOpTag CopyByteArrayToAddrOp = 465 -primOpTag CopyMutableByteArrayToAddrOp = 466 -primOpTag CopyAddrToByteArrayOp = 467 -primOpTag SetByteArrayOp = 468 -primOpTag AtomicReadByteArrayOp_Int = 469 -primOpTag AtomicWriteByteArrayOp_Int = 470 -primOpTag CasByteArrayOp_Int = 471 -primOpTag CasByteArrayOp_Int8 = 472 -primOpTag CasByteArrayOp_Int16 = 473 -primOpTag CasByteArrayOp_Int32 = 474 -primOpTag CasByteArrayOp_Int64 = 475 -primOpTag FetchAddByteArrayOp_Int = 476 -primOpTag FetchSubByteArrayOp_Int = 477 -primOpTag FetchAndByteArrayOp_Int = 478 -primOpTag FetchNandByteArrayOp_Int = 479 -primOpTag FetchOrByteArrayOp_Int = 480 -primOpTag FetchXorByteArrayOp_Int = 481 -primOpTag NewArrayArrayOp = 482 -primOpTag UnsafeFreezeArrayArrayOp = 483 -primOpTag SizeofArrayArrayOp = 484 -primOpTag SizeofMutableArrayArrayOp = 485 -primOpTag IndexArrayArrayOp_ByteArray = 486 -primOpTag IndexArrayArrayOp_ArrayArray = 487 -primOpTag ReadArrayArrayOp_ByteArray = 488 -primOpTag ReadArrayArrayOp_MutableByteArray = 489 -primOpTag ReadArrayArrayOp_ArrayArray = 490 -primOpTag ReadArrayArrayOp_MutableArrayArray = 491 -primOpTag WriteArrayArrayOp_ByteArray = 492 -primOpTag WriteArrayArrayOp_MutableByteArray = 493 -primOpTag WriteArrayArrayOp_ArrayArray = 494 -primOpTag WriteArrayArrayOp_MutableArrayArray = 495 -primOpTag CopyArrayArrayOp = 496 -primOpTag CopyMutableArrayArrayOp = 497 -primOpTag AddrAddOp = 498 -primOpTag AddrSubOp = 499 -primOpTag AddrRemOp = 500 -primOpTag AddrToIntOp = 501 -primOpTag IntToAddrOp = 502 -primOpTag AddrGtOp = 503 -primOpTag AddrGeOp = 504 -primOpTag AddrEqOp = 505 -primOpTag AddrNeOp = 506 -primOpTag AddrLtOp = 507 -primOpTag AddrLeOp = 508 -primOpTag IndexOffAddrOp_Char = 509 -primOpTag IndexOffAddrOp_WideChar = 510 -primOpTag IndexOffAddrOp_Int = 511 -primOpTag IndexOffAddrOp_Word = 512 -primOpTag IndexOffAddrOp_Addr = 513 -primOpTag IndexOffAddrOp_Float = 514 -primOpTag IndexOffAddrOp_Double = 515 -primOpTag IndexOffAddrOp_StablePtr = 516 -primOpTag IndexOffAddrOp_Int8 = 517 -primOpTag IndexOffAddrOp_Int16 = 518 -primOpTag IndexOffAddrOp_Int32 = 519 -primOpTag IndexOffAddrOp_Int64 = 520 -primOpTag IndexOffAddrOp_Word8 = 521 -primOpTag IndexOffAddrOp_Word16 = 522 -primOpTag IndexOffAddrOp_Word32 = 523 -primOpTag IndexOffAddrOp_Word64 = 524 -primOpTag ReadOffAddrOp_Char = 525 -primOpTag ReadOffAddrOp_WideChar = 526 -primOpTag ReadOffAddrOp_Int = 527 -primOpTag ReadOffAddrOp_Word = 528 -primOpTag ReadOffAddrOp_Addr = 529 -primOpTag ReadOffAddrOp_Float = 530 -primOpTag ReadOffAddrOp_Double = 531 -primOpTag ReadOffAddrOp_StablePtr = 532 -primOpTag ReadOffAddrOp_Int8 = 533 -primOpTag ReadOffAddrOp_Int16 = 534 -primOpTag ReadOffAddrOp_Int32 = 535 -primOpTag ReadOffAddrOp_Int64 = 536 -primOpTag ReadOffAddrOp_Word8 = 537 -primOpTag ReadOffAddrOp_Word16 = 538 -primOpTag ReadOffAddrOp_Word32 = 539 -primOpTag ReadOffAddrOp_Word64 = 540 -primOpTag WriteOffAddrOp_Char = 541 -primOpTag WriteOffAddrOp_WideChar = 542 -primOpTag WriteOffAddrOp_Int = 543 -primOpTag WriteOffAddrOp_Word = 544 -primOpTag WriteOffAddrOp_Addr = 545 -primOpTag WriteOffAddrOp_Float = 546 -primOpTag WriteOffAddrOp_Double = 547 -primOpTag WriteOffAddrOp_StablePtr = 548 -primOpTag WriteOffAddrOp_Int8 = 549 -primOpTag WriteOffAddrOp_Int16 = 550 -primOpTag WriteOffAddrOp_Int32 = 551 -primOpTag WriteOffAddrOp_Int64 = 552 -primOpTag WriteOffAddrOp_Word8 = 553 -primOpTag WriteOffAddrOp_Word16 = 554 -primOpTag WriteOffAddrOp_Word32 = 555 -primOpTag WriteOffAddrOp_Word64 = 556 -primOpTag InterlockedExchange_Addr = 557 -primOpTag InterlockedExchange_Word = 558 -primOpTag CasAddrOp_Addr = 559 -primOpTag CasAddrOp_Word = 560 -primOpTag CasAddrOp_Word8 = 561 -primOpTag CasAddrOp_Word16 = 562 -primOpTag CasAddrOp_Word32 = 563 -primOpTag CasAddrOp_Word64 = 564 -primOpTag FetchAddAddrOp_Word = 565 -primOpTag FetchSubAddrOp_Word = 566 -primOpTag FetchAndAddrOp_Word = 567 -primOpTag FetchNandAddrOp_Word = 568 -primOpTag FetchOrAddrOp_Word = 569 -primOpTag FetchXorAddrOp_Word = 570 -primOpTag AtomicReadAddrOp_Word = 571 -primOpTag AtomicWriteAddrOp_Word = 572 -primOpTag NewMutVarOp = 573 -primOpTag ReadMutVarOp = 574 -primOpTag WriteMutVarOp = 575 -primOpTag AtomicModifyMutVar2Op = 576 -primOpTag AtomicModifyMutVar_Op = 577 -primOpTag CasMutVarOp = 578 -primOpTag CatchOp = 579 -primOpTag RaiseOp = 580 -primOpTag RaiseIOOp = 581 -primOpTag MaskAsyncExceptionsOp = 582 -primOpTag MaskUninterruptibleOp = 583 -primOpTag UnmaskAsyncExceptionsOp = 584 -primOpTag MaskStatus = 585 -primOpTag AtomicallyOp = 586 -primOpTag RetryOp = 587 -primOpTag CatchRetryOp = 588 -primOpTag CatchSTMOp = 589 -primOpTag NewTVarOp = 590 -primOpTag ReadTVarOp = 591 -primOpTag ReadTVarIOOp = 592 -primOpTag WriteTVarOp = 593 -primOpTag NewMVarOp = 594 -primOpTag TakeMVarOp = 595 -primOpTag TryTakeMVarOp = 596 -primOpTag PutMVarOp = 597 -primOpTag TryPutMVarOp = 598 -primOpTag ReadMVarOp = 599 -primOpTag TryReadMVarOp = 600 -primOpTag IsEmptyMVarOp = 601 -primOpTag NewIOPortrOp = 602 -primOpTag ReadIOPortOp = 603 -primOpTag WriteIOPortOp = 604 -primOpTag DelayOp = 605 -primOpTag WaitReadOp = 606 -primOpTag WaitWriteOp = 607 -primOpTag ForkOp = 608 -primOpTag ForkOnOp = 609 -primOpTag KillThreadOp = 610 -primOpTag YieldOp = 611 -primOpTag MyThreadIdOp = 612 -primOpTag LabelThreadOp = 613 -primOpTag IsCurrentThreadBoundOp = 614 -primOpTag NoDuplicateOp = 615 -primOpTag ThreadStatusOp = 616 -primOpTag MkWeakOp = 617 -primOpTag MkWeakNoFinalizerOp = 618 -primOpTag AddCFinalizerToWeakOp = 619 -primOpTag DeRefWeakOp = 620 -primOpTag FinalizeWeakOp = 621 -primOpTag TouchOp = 622 -primOpTag MakeStablePtrOp = 623 -primOpTag DeRefStablePtrOp = 624 -primOpTag EqStablePtrOp = 625 -primOpTag MakeStableNameOp = 626 -primOpTag StableNameToIntOp = 627 -primOpTag CompactNewOp = 628 -primOpTag CompactResizeOp = 629 -primOpTag CompactContainsOp = 630 -primOpTag CompactContainsAnyOp = 631 -primOpTag CompactGetFirstBlockOp = 632 -primOpTag CompactGetNextBlockOp = 633 -primOpTag CompactAllocateBlockOp = 634 -primOpTag CompactFixupPointersOp = 635 -primOpTag CompactAdd = 636 -primOpTag CompactAddWithSharing = 637 -primOpTag CompactSize = 638 -primOpTag ReallyUnsafePtrEqualityOp = 639 -primOpTag ParOp = 640 -primOpTag SparkOp = 641 -primOpTag SeqOp = 642 -primOpTag GetSparkOp = 643 -primOpTag NumSparks = 644 -primOpTag KeepAliveOp = 645 -primOpTag DataToTagOp = 646 -primOpTag TagToEnumOp = 647 -primOpTag AddrToAnyOp = 648 -primOpTag AnyToAddrOp = 649 -primOpTag MkApUpd0_Op = 650 -primOpTag NewBCOOp = 651 -primOpTag UnpackClosureOp = 652 -primOpTag ClosureSizeOp = 653 -primOpTag GetApStackValOp = 654 -primOpTag GetCCSOfOp = 655 -primOpTag GetCurrentCCSOp = 656 -primOpTag ClearCCSOp = 657 -primOpTag WhereFromOp = 658 -primOpTag TraceEventOp = 659 -primOpTag TraceEventBinaryOp = 660 -primOpTag TraceMarkerOp = 661 -primOpTag SetThreadAllocationCounter = 662 -primOpTag (VecBroadcastOp IntVec 16 W8) = 663 -primOpTag (VecBroadcastOp IntVec 8 W16) = 664 -primOpTag (VecBroadcastOp IntVec 4 W32) = 665 -primOpTag (VecBroadcastOp IntVec 2 W64) = 666 -primOpTag (VecBroadcastOp IntVec 32 W8) = 667 -primOpTag (VecBroadcastOp IntVec 16 W16) = 668 -primOpTag (VecBroadcastOp IntVec 8 W32) = 669 -primOpTag (VecBroadcastOp IntVec 4 W64) = 670 -primOpTag (VecBroadcastOp IntVec 64 W8) = 671 -primOpTag (VecBroadcastOp IntVec 32 W16) = 672 -primOpTag (VecBroadcastOp IntVec 16 W32) = 673 -primOpTag (VecBroadcastOp IntVec 8 W64) = 674 -primOpTag (VecBroadcastOp WordVec 16 W8) = 675 -primOpTag (VecBroadcastOp WordVec 8 W16) = 676 -primOpTag (VecBroadcastOp WordVec 4 W32) = 677 -primOpTag (VecBroadcastOp WordVec 2 W64) = 678 -primOpTag (VecBroadcastOp WordVec 32 W8) = 679 -primOpTag (VecBroadcastOp WordVec 16 W16) = 680 -primOpTag (VecBroadcastOp WordVec 8 W32) = 681 -primOpTag (VecBroadcastOp WordVec 4 W64) = 682 -primOpTag (VecBroadcastOp WordVec 64 W8) = 683 -primOpTag (VecBroadcastOp WordVec 32 W16) = 684 -primOpTag (VecBroadcastOp WordVec 16 W32) = 685 -primOpTag (VecBroadcastOp WordVec 8 W64) = 686 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 687 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 688 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 689 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 690 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 691 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 692 -primOpTag (VecPackOp IntVec 16 W8) = 693 -primOpTag (VecPackOp IntVec 8 W16) = 694 -primOpTag (VecPackOp IntVec 4 W32) = 695 -primOpTag (VecPackOp IntVec 2 W64) = 696 -primOpTag (VecPackOp IntVec 32 W8) = 697 -primOpTag (VecPackOp IntVec 16 W16) = 698 -primOpTag (VecPackOp IntVec 8 W32) = 699 -primOpTag (VecPackOp IntVec 4 W64) = 700 -primOpTag (VecPackOp IntVec 64 W8) = 701 -primOpTag (VecPackOp IntVec 32 W16) = 702 -primOpTag (VecPackOp IntVec 16 W32) = 703 -primOpTag (VecPackOp IntVec 8 W64) = 704 -primOpTag (VecPackOp WordVec 16 W8) = 705 -primOpTag (VecPackOp WordVec 8 W16) = 706 -primOpTag (VecPackOp WordVec 4 W32) = 707 -primOpTag (VecPackOp WordVec 2 W64) = 708 -primOpTag (VecPackOp WordVec 32 W8) = 709 -primOpTag (VecPackOp WordVec 16 W16) = 710 -primOpTag (VecPackOp WordVec 8 W32) = 711 -primOpTag (VecPackOp WordVec 4 W64) = 712 -primOpTag (VecPackOp WordVec 64 W8) = 713 -primOpTag (VecPackOp WordVec 32 W16) = 714 -primOpTag (VecPackOp WordVec 16 W32) = 715 -primOpTag (VecPackOp WordVec 8 W64) = 716 -primOpTag (VecPackOp FloatVec 4 W32) = 717 -primOpTag (VecPackOp FloatVec 2 W64) = 718 -primOpTag (VecPackOp FloatVec 8 W32) = 719 -primOpTag (VecPackOp FloatVec 4 W64) = 720 -primOpTag (VecPackOp FloatVec 16 W32) = 721 -primOpTag (VecPackOp FloatVec 8 W64) = 722 -primOpTag (VecUnpackOp IntVec 16 W8) = 723 -primOpTag (VecUnpackOp IntVec 8 W16) = 724 -primOpTag (VecUnpackOp IntVec 4 W32) = 725 -primOpTag (VecUnpackOp IntVec 2 W64) = 726 -primOpTag (VecUnpackOp IntVec 32 W8) = 727 -primOpTag (VecUnpackOp IntVec 16 W16) = 728 -primOpTag (VecUnpackOp IntVec 8 W32) = 729 -primOpTag (VecUnpackOp IntVec 4 W64) = 730 -primOpTag (VecUnpackOp IntVec 64 W8) = 731 -primOpTag (VecUnpackOp IntVec 32 W16) = 732 -primOpTag (VecUnpackOp IntVec 16 W32) = 733 -primOpTag (VecUnpackOp IntVec 8 W64) = 734 -primOpTag (VecUnpackOp WordVec 16 W8) = 735 -primOpTag (VecUnpackOp WordVec 8 W16) = 736 -primOpTag (VecUnpackOp WordVec 4 W32) = 737 -primOpTag (VecUnpackOp WordVec 2 W64) = 738 -primOpTag (VecUnpackOp WordVec 32 W8) = 739 -primOpTag (VecUnpackOp WordVec 16 W16) = 740 -primOpTag (VecUnpackOp WordVec 8 W32) = 741 -primOpTag (VecUnpackOp WordVec 4 W64) = 742 -primOpTag (VecUnpackOp WordVec 64 W8) = 743 -primOpTag (VecUnpackOp WordVec 32 W16) = 744 -primOpTag (VecUnpackOp WordVec 16 W32) = 745 -primOpTag (VecUnpackOp WordVec 8 W64) = 746 -primOpTag (VecUnpackOp FloatVec 4 W32) = 747 -primOpTag (VecUnpackOp FloatVec 2 W64) = 748 -primOpTag (VecUnpackOp FloatVec 8 W32) = 749 -primOpTag (VecUnpackOp FloatVec 4 W64) = 750 -primOpTag (VecUnpackOp FloatVec 16 W32) = 751 -primOpTag (VecUnpackOp FloatVec 8 W64) = 752 -primOpTag (VecInsertOp IntVec 16 W8) = 753 -primOpTag (VecInsertOp IntVec 8 W16) = 754 -primOpTag (VecInsertOp IntVec 4 W32) = 755 -primOpTag (VecInsertOp IntVec 2 W64) = 756 -primOpTag (VecInsertOp IntVec 32 W8) = 757 -primOpTag (VecInsertOp IntVec 16 W16) = 758 -primOpTag (VecInsertOp IntVec 8 W32) = 759 -primOpTag (VecInsertOp IntVec 4 W64) = 760 -primOpTag (VecInsertOp IntVec 64 W8) = 761 -primOpTag (VecInsertOp IntVec 32 W16) = 762 -primOpTag (VecInsertOp IntVec 16 W32) = 763 -primOpTag (VecInsertOp IntVec 8 W64) = 764 -primOpTag (VecInsertOp WordVec 16 W8) = 765 -primOpTag (VecInsertOp WordVec 8 W16) = 766 -primOpTag (VecInsertOp WordVec 4 W32) = 767 -primOpTag (VecInsertOp WordVec 2 W64) = 768 -primOpTag (VecInsertOp WordVec 32 W8) = 769 -primOpTag (VecInsertOp WordVec 16 W16) = 770 -primOpTag (VecInsertOp WordVec 8 W32) = 771 -primOpTag (VecInsertOp WordVec 4 W64) = 772 -primOpTag (VecInsertOp WordVec 64 W8) = 773 -primOpTag (VecInsertOp WordVec 32 W16) = 774 -primOpTag (VecInsertOp WordVec 16 W32) = 775 -primOpTag (VecInsertOp WordVec 8 W64) = 776 -primOpTag (VecInsertOp FloatVec 4 W32) = 777 -primOpTag (VecInsertOp FloatVec 2 W64) = 778 -primOpTag (VecInsertOp FloatVec 8 W32) = 779 -primOpTag (VecInsertOp FloatVec 4 W64) = 780 -primOpTag (VecInsertOp FloatVec 16 W32) = 781 -primOpTag (VecInsertOp FloatVec 8 W64) = 782 -primOpTag (VecAddOp IntVec 16 W8) = 783 -primOpTag (VecAddOp IntVec 8 W16) = 784 -primOpTag (VecAddOp IntVec 4 W32) = 785 -primOpTag (VecAddOp IntVec 2 W64) = 786 -primOpTag (VecAddOp IntVec 32 W8) = 787 -primOpTag (VecAddOp IntVec 16 W16) = 788 -primOpTag (VecAddOp IntVec 8 W32) = 789 -primOpTag (VecAddOp IntVec 4 W64) = 790 -primOpTag (VecAddOp IntVec 64 W8) = 791 -primOpTag (VecAddOp IntVec 32 W16) = 792 -primOpTag (VecAddOp IntVec 16 W32) = 793 -primOpTag (VecAddOp IntVec 8 W64) = 794 -primOpTag (VecAddOp WordVec 16 W8) = 795 -primOpTag (VecAddOp WordVec 8 W16) = 796 -primOpTag (VecAddOp WordVec 4 W32) = 797 -primOpTag (VecAddOp WordVec 2 W64) = 798 -primOpTag (VecAddOp WordVec 32 W8) = 799 -primOpTag (VecAddOp WordVec 16 W16) = 800 -primOpTag (VecAddOp WordVec 8 W32) = 801 -primOpTag (VecAddOp WordVec 4 W64) = 802 -primOpTag (VecAddOp WordVec 64 W8) = 803 -primOpTag (VecAddOp WordVec 32 W16) = 804 -primOpTag (VecAddOp WordVec 16 W32) = 805 -primOpTag (VecAddOp WordVec 8 W64) = 806 -primOpTag (VecAddOp FloatVec 4 W32) = 807 -primOpTag (VecAddOp FloatVec 2 W64) = 808 -primOpTag (VecAddOp FloatVec 8 W32) = 809 -primOpTag (VecAddOp FloatVec 4 W64) = 810 -primOpTag (VecAddOp FloatVec 16 W32) = 811 -primOpTag (VecAddOp FloatVec 8 W64) = 812 -primOpTag (VecSubOp IntVec 16 W8) = 813 -primOpTag (VecSubOp IntVec 8 W16) = 814 -primOpTag (VecSubOp IntVec 4 W32) = 815 -primOpTag (VecSubOp IntVec 2 W64) = 816 -primOpTag (VecSubOp IntVec 32 W8) = 817 -primOpTag (VecSubOp IntVec 16 W16) = 818 -primOpTag (VecSubOp IntVec 8 W32) = 819 -primOpTag (VecSubOp IntVec 4 W64) = 820 -primOpTag (VecSubOp IntVec 64 W8) = 821 -primOpTag (VecSubOp IntVec 32 W16) = 822 -primOpTag (VecSubOp IntVec 16 W32) = 823 -primOpTag (VecSubOp IntVec 8 W64) = 824 -primOpTag (VecSubOp WordVec 16 W8) = 825 -primOpTag (VecSubOp WordVec 8 W16) = 826 -primOpTag (VecSubOp WordVec 4 W32) = 827 -primOpTag (VecSubOp WordVec 2 W64) = 828 -primOpTag (VecSubOp WordVec 32 W8) = 829 -primOpTag (VecSubOp WordVec 16 W16) = 830 -primOpTag (VecSubOp WordVec 8 W32) = 831 -primOpTag (VecSubOp WordVec 4 W64) = 832 -primOpTag (VecSubOp WordVec 64 W8) = 833 -primOpTag (VecSubOp WordVec 32 W16) = 834 -primOpTag (VecSubOp WordVec 16 W32) = 835 -primOpTag (VecSubOp WordVec 8 W64) = 836 -primOpTag (VecSubOp FloatVec 4 W32) = 837 -primOpTag (VecSubOp FloatVec 2 W64) = 838 -primOpTag (VecSubOp FloatVec 8 W32) = 839 -primOpTag (VecSubOp FloatVec 4 W64) = 840 -primOpTag (VecSubOp FloatVec 16 W32) = 841 -primOpTag (VecSubOp FloatVec 8 W64) = 842 -primOpTag (VecMulOp IntVec 16 W8) = 843 -primOpTag (VecMulOp IntVec 8 W16) = 844 -primOpTag (VecMulOp IntVec 4 W32) = 845 -primOpTag (VecMulOp IntVec 2 W64) = 846 -primOpTag (VecMulOp IntVec 32 W8) = 847 -primOpTag (VecMulOp IntVec 16 W16) = 848 -primOpTag (VecMulOp IntVec 8 W32) = 849 -primOpTag (VecMulOp IntVec 4 W64) = 850 -primOpTag (VecMulOp IntVec 64 W8) = 851 -primOpTag (VecMulOp IntVec 32 W16) = 852 -primOpTag (VecMulOp IntVec 16 W32) = 853 -primOpTag (VecMulOp IntVec 8 W64) = 854 -primOpTag (VecMulOp WordVec 16 W8) = 855 -primOpTag (VecMulOp WordVec 8 W16) = 856 -primOpTag (VecMulOp WordVec 4 W32) = 857 -primOpTag (VecMulOp WordVec 2 W64) = 858 -primOpTag (VecMulOp WordVec 32 W8) = 859 -primOpTag (VecMulOp WordVec 16 W16) = 860 -primOpTag (VecMulOp WordVec 8 W32) = 861 -primOpTag (VecMulOp WordVec 4 W64) = 862 -primOpTag (VecMulOp WordVec 64 W8) = 863 -primOpTag (VecMulOp WordVec 32 W16) = 864 -primOpTag (VecMulOp WordVec 16 W32) = 865 -primOpTag (VecMulOp WordVec 8 W64) = 866 -primOpTag (VecMulOp FloatVec 4 W32) = 867 -primOpTag (VecMulOp FloatVec 2 W64) = 868 -primOpTag (VecMulOp FloatVec 8 W32) = 869 -primOpTag (VecMulOp FloatVec 4 W64) = 870 -primOpTag (VecMulOp FloatVec 16 W32) = 871 -primOpTag (VecMulOp FloatVec 8 W64) = 872 -primOpTag (VecDivOp FloatVec 4 W32) = 873 -primOpTag (VecDivOp FloatVec 2 W64) = 874 -primOpTag (VecDivOp FloatVec 8 W32) = 875 -primOpTag (VecDivOp FloatVec 4 W64) = 876 -primOpTag (VecDivOp FloatVec 16 W32) = 877 -primOpTag (VecDivOp FloatVec 8 W64) = 878 -primOpTag (VecQuotOp IntVec 16 W8) = 879 -primOpTag (VecQuotOp IntVec 8 W16) = 880 -primOpTag (VecQuotOp IntVec 4 W32) = 881 -primOpTag (VecQuotOp IntVec 2 W64) = 882 -primOpTag (VecQuotOp IntVec 32 W8) = 883 -primOpTag (VecQuotOp IntVec 16 W16) = 884 -primOpTag (VecQuotOp IntVec 8 W32) = 885 -primOpTag (VecQuotOp IntVec 4 W64) = 886 -primOpTag (VecQuotOp IntVec 64 W8) = 887 -primOpTag (VecQuotOp IntVec 32 W16) = 888 -primOpTag (VecQuotOp IntVec 16 W32) = 889 -primOpTag (VecQuotOp IntVec 8 W64) = 890 -primOpTag (VecQuotOp WordVec 16 W8) = 891 -primOpTag (VecQuotOp WordVec 8 W16) = 892 -primOpTag (VecQuotOp WordVec 4 W32) = 893 -primOpTag (VecQuotOp WordVec 2 W64) = 894 -primOpTag (VecQuotOp WordVec 32 W8) = 895 -primOpTag (VecQuotOp WordVec 16 W16) = 896 -primOpTag (VecQuotOp WordVec 8 W32) = 897 -primOpTag (VecQuotOp WordVec 4 W64) = 898 -primOpTag (VecQuotOp WordVec 64 W8) = 899 -primOpTag (VecQuotOp WordVec 32 W16) = 900 -primOpTag (VecQuotOp WordVec 16 W32) = 901 -primOpTag (VecQuotOp WordVec 8 W64) = 902 -primOpTag (VecRemOp IntVec 16 W8) = 903 -primOpTag (VecRemOp IntVec 8 W16) = 904 -primOpTag (VecRemOp IntVec 4 W32) = 905 -primOpTag (VecRemOp IntVec 2 W64) = 906 -primOpTag (VecRemOp IntVec 32 W8) = 907 -primOpTag (VecRemOp IntVec 16 W16) = 908 -primOpTag (VecRemOp IntVec 8 W32) = 909 -primOpTag (VecRemOp IntVec 4 W64) = 910 -primOpTag (VecRemOp IntVec 64 W8) = 911 -primOpTag (VecRemOp IntVec 32 W16) = 912 -primOpTag (VecRemOp IntVec 16 W32) = 913 -primOpTag (VecRemOp IntVec 8 W64) = 914 -primOpTag (VecRemOp WordVec 16 W8) = 915 -primOpTag (VecRemOp WordVec 8 W16) = 916 -primOpTag (VecRemOp WordVec 4 W32) = 917 -primOpTag (VecRemOp WordVec 2 W64) = 918 -primOpTag (VecRemOp WordVec 32 W8) = 919 -primOpTag (VecRemOp WordVec 16 W16) = 920 -primOpTag (VecRemOp WordVec 8 W32) = 921 -primOpTag (VecRemOp WordVec 4 W64) = 922 -primOpTag (VecRemOp WordVec 64 W8) = 923 -primOpTag (VecRemOp WordVec 32 W16) = 924 -primOpTag (VecRemOp WordVec 16 W32) = 925 -primOpTag (VecRemOp WordVec 8 W64) = 926 -primOpTag (VecNegOp IntVec 16 W8) = 927 -primOpTag (VecNegOp IntVec 8 W16) = 928 -primOpTag (VecNegOp IntVec 4 W32) = 929 -primOpTag (VecNegOp IntVec 2 W64) = 930 -primOpTag (VecNegOp IntVec 32 W8) = 931 -primOpTag (VecNegOp IntVec 16 W16) = 932 -primOpTag (VecNegOp IntVec 8 W32) = 933 -primOpTag (VecNegOp IntVec 4 W64) = 934 -primOpTag (VecNegOp IntVec 64 W8) = 935 -primOpTag (VecNegOp IntVec 32 W16) = 936 -primOpTag (VecNegOp IntVec 16 W32) = 937 -primOpTag (VecNegOp IntVec 8 W64) = 938 -primOpTag (VecNegOp FloatVec 4 W32) = 939 -primOpTag (VecNegOp FloatVec 2 W64) = 940 -primOpTag (VecNegOp FloatVec 8 W32) = 941 -primOpTag (VecNegOp FloatVec 4 W64) = 942 -primOpTag (VecNegOp FloatVec 16 W32) = 943 -primOpTag (VecNegOp FloatVec 8 W64) = 944 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 945 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 946 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 947 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 948 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 949 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 950 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 951 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 952 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 953 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 954 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 955 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 956 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 957 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 958 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 959 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 960 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 961 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 962 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 963 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 964 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 965 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 966 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 967 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 968 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 969 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 970 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 971 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 972 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 973 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 974 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 975 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 976 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 977 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 978 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 979 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 980 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 981 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 982 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 983 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 984 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 985 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 986 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 987 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 988 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 989 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 990 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 991 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 992 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 993 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 994 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 995 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 996 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 997 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 998 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 999 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1000 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1001 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1002 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1003 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1004 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1005 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1006 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1007 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1008 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1009 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1010 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1011 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1012 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1013 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1014 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1015 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1016 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1017 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1018 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1019 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1020 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1021 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1022 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1023 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1024 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1025 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1026 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1027 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1028 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1029 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1030 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1031 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1032 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1033 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1034 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1035 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1036 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1037 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1038 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1039 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1040 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1041 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1042 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1043 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1044 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1045 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1046 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1047 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1048 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1049 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1050 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1051 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1052 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1053 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1054 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1055 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1056 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1057 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1058 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1059 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1060 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1061 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1062 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1063 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1064 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1065 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1066 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1067 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1068 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1069 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1070 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1071 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1072 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1073 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1074 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1075 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1076 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1077 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1078 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1079 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1080 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1081 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1082 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1083 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1084 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1085 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1086 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1087 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1088 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1089 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1090 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1091 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1092 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1093 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1094 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1095 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1096 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1097 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1098 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1099 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1100 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1101 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1102 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1103 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1104 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1105 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1106 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1107 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1108 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1109 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1110 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1111 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1112 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1113 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1114 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1115 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1116 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1117 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1118 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1119 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1120 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1121 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1122 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1123 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1124 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1125 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1126 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1127 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1128 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1129 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1130 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1131 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1132 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1133 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1134 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1135 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1136 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1137 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1138 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1139 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1140 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1141 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1142 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1143 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1144 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1145 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1146 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1147 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1148 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1149 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1150 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1151 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1152 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1153 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1154 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1155 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1156 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1157 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1158 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1159 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1160 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1161 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1162 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1163 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1164 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1165 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1166 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1167 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1168 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1169 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1170 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1171 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1172 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1173 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1174 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1175 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1176 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1177 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1178 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1179 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1180 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1181 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1182 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1183 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1184 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1185 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1186 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1187 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1188 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1189 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1190 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1191 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1192 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1193 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1194 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1195 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1196 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1197 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1198 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1199 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1200 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1201 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1202 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1203 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1204 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1205 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1206 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1207 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1208 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1209 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1210 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1211 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1212 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1213 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1214 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1215 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1216 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1217 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1218 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1219 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1220 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1221 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1222 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1223 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1224 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1225 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1226 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1227 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1228 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1229 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1230 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1231 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1232 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1233 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1234 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1235 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1236 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1237 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1238 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1239 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1240 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1241 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1242 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1243 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1244 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1245 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1246 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1247 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1248 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1249 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1250 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1251 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1252 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1253 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1254 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1255 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1256 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1257 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1258 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1259 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1260 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1261 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1262 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1263 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1264 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1265 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1266 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1267 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1268 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1269 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1270 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1271 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1272 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1273 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1274 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1275 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1276 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1277 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1278 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1279 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1280 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1281 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1282 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1283 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1284 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1285 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1286 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1287 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1288 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1289 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1290 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1291 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1292 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1293 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1294 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1295 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1296 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1297 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1298 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1299 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1300 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1301 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1302 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1303 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1304 -primOpTag PrefetchByteArrayOp3 = 1305 -primOpTag PrefetchMutableByteArrayOp3 = 1306 -primOpTag PrefetchAddrOp3 = 1307 -primOpTag PrefetchValueOp3 = 1308 -primOpTag PrefetchByteArrayOp2 = 1309 -primOpTag PrefetchMutableByteArrayOp2 = 1310 -primOpTag PrefetchAddrOp2 = 1311 -primOpTag PrefetchValueOp2 = 1312 -primOpTag PrefetchByteArrayOp1 = 1313 -primOpTag PrefetchMutableByteArrayOp1 = 1314 -primOpTag PrefetchAddrOp1 = 1315 -primOpTag PrefetchValueOp1 = 1316 -primOpTag PrefetchByteArrayOp0 = 1317 -primOpTag PrefetchMutableByteArrayOp0 = 1318 -primOpTag PrefetchAddrOp0 = 1319 -primOpTag PrefetchValueOp0 = 1320 +maxPrimOpTag = 1303 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 0 +primOpTag CharGeOp = 1 +primOpTag CharEqOp = 2 +primOpTag CharNeOp = 3 +primOpTag CharLtOp = 4 +primOpTag CharLeOp = 5 +primOpTag OrdOp = 6 +primOpTag Int8ToIntOp = 7 +primOpTag IntToInt8Op = 8 +primOpTag Int8NegOp = 9 +primOpTag Int8AddOp = 10 +primOpTag Int8SubOp = 11 +primOpTag Int8MulOp = 12 +primOpTag Int8QuotOp = 13 +primOpTag Int8RemOp = 14 +primOpTag Int8QuotRemOp = 15 +primOpTag Int8SllOp = 16 +primOpTag Int8SraOp = 17 +primOpTag Int8SrlOp = 18 +primOpTag Int8ToWord8Op = 19 +primOpTag Int8EqOp = 20 +primOpTag Int8GeOp = 21 +primOpTag Int8GtOp = 22 +primOpTag Int8LeOp = 23 +primOpTag Int8LtOp = 24 +primOpTag Int8NeOp = 25 +primOpTag Word8ToWordOp = 26 +primOpTag WordToWord8Op = 27 +primOpTag Word8AddOp = 28 +primOpTag Word8SubOp = 29 +primOpTag Word8MulOp = 30 +primOpTag Word8QuotOp = 31 +primOpTag Word8RemOp = 32 +primOpTag Word8QuotRemOp = 33 +primOpTag Word8AndOp = 34 +primOpTag Word8OrOp = 35 +primOpTag Word8XorOp = 36 +primOpTag Word8NotOp = 37 +primOpTag Word8SllOp = 38 +primOpTag Word8SrlOp = 39 +primOpTag Word8ToInt8Op = 40 +primOpTag Word8EqOp = 41 +primOpTag Word8GeOp = 42 +primOpTag Word8GtOp = 43 +primOpTag Word8LeOp = 44 +primOpTag Word8LtOp = 45 +primOpTag Word8NeOp = 46 +primOpTag Int16ToIntOp = 47 +primOpTag IntToInt16Op = 48 +primOpTag Int16NegOp = 49 +primOpTag Int16AddOp = 50 +primOpTag Int16SubOp = 51 +primOpTag Int16MulOp = 52 +primOpTag Int16QuotOp = 53 +primOpTag Int16RemOp = 54 +primOpTag Int16QuotRemOp = 55 +primOpTag Int16SllOp = 56 +primOpTag Int16SraOp = 57 +primOpTag Int16SrlOp = 58 +primOpTag Int16ToWord16Op = 59 +primOpTag Int16EqOp = 60 +primOpTag Int16GeOp = 61 +primOpTag Int16GtOp = 62 +primOpTag Int16LeOp = 63 +primOpTag Int16LtOp = 64 +primOpTag Int16NeOp = 65 +primOpTag Word16ToWordOp = 66 +primOpTag WordToWord16Op = 67 +primOpTag Word16AddOp = 68 +primOpTag Word16SubOp = 69 +primOpTag Word16MulOp = 70 +primOpTag Word16QuotOp = 71 +primOpTag Word16RemOp = 72 +primOpTag Word16QuotRemOp = 73 +primOpTag Word16AndOp = 74 +primOpTag Word16OrOp = 75 +primOpTag Word16XorOp = 76 +primOpTag Word16NotOp = 77 +primOpTag Word16SllOp = 78 +primOpTag Word16SrlOp = 79 +primOpTag Word16ToInt16Op = 80 +primOpTag Word16EqOp = 81 +primOpTag Word16GeOp = 82 +primOpTag Word16GtOp = 83 +primOpTag Word16LeOp = 84 +primOpTag Word16LtOp = 85 +primOpTag Word16NeOp = 86 +primOpTag Int32ToIntOp = 87 +primOpTag IntToInt32Op = 88 +primOpTag Int32NegOp = 89 +primOpTag Int32AddOp = 90 +primOpTag Int32SubOp = 91 +primOpTag Int32MulOp = 92 +primOpTag Int32QuotOp = 93 +primOpTag Int32RemOp = 94 +primOpTag Int32QuotRemOp = 95 +primOpTag Int32SllOp = 96 +primOpTag Int32SraOp = 97 +primOpTag Int32SrlOp = 98 +primOpTag Int32ToWord32Op = 99 +primOpTag Int32EqOp = 100 +primOpTag Int32GeOp = 101 +primOpTag Int32GtOp = 102 +primOpTag Int32LeOp = 103 +primOpTag Int32LtOp = 104 +primOpTag Int32NeOp = 105 +primOpTag Word32ToWordOp = 106 +primOpTag WordToWord32Op = 107 +primOpTag Word32AddOp = 108 +primOpTag Word32SubOp = 109 +primOpTag Word32MulOp = 110 +primOpTag Word32QuotOp = 111 +primOpTag Word32RemOp = 112 +primOpTag Word32QuotRemOp = 113 +primOpTag Word32AndOp = 114 +primOpTag Word32OrOp = 115 +primOpTag Word32XorOp = 116 +primOpTag Word32NotOp = 117 +primOpTag Word32SllOp = 118 +primOpTag Word32SrlOp = 119 +primOpTag Word32ToInt32Op = 120 +primOpTag Word32EqOp = 121 +primOpTag Word32GeOp = 122 +primOpTag Word32GtOp = 123 +primOpTag Word32LeOp = 124 +primOpTag Word32LtOp = 125 +primOpTag Word32NeOp = 126 +primOpTag Int64ToIntOp = 127 +primOpTag IntToInt64Op = 128 +primOpTag Int64NegOp = 129 +primOpTag Int64AddOp = 130 +primOpTag Int64SubOp = 131 +primOpTag Int64MulOp = 132 +primOpTag Int64QuotOp = 133 +primOpTag Int64RemOp = 134 +primOpTag Int64SllOp = 135 +primOpTag Int64SraOp = 136 +primOpTag Int64SrlOp = 137 +primOpTag Int64ToWord64Op = 138 +primOpTag Int64EqOp = 139 +primOpTag Int64GeOp = 140 +primOpTag Int64GtOp = 141 +primOpTag Int64LeOp = 142 +primOpTag Int64LtOp = 143 +primOpTag Int64NeOp = 144 +primOpTag Word64ToWordOp = 145 +primOpTag WordToWord64Op = 146 +primOpTag Word64AddOp = 147 +primOpTag Word64SubOp = 148 +primOpTag Word64MulOp = 149 +primOpTag Word64QuotOp = 150 +primOpTag Word64RemOp = 151 +primOpTag Word64AndOp = 152 +primOpTag Word64OrOp = 153 +primOpTag Word64XorOp = 154 +primOpTag Word64NotOp = 155 +primOpTag Word64SllOp = 156 +primOpTag Word64SrlOp = 157 +primOpTag Word64ToInt64Op = 158 +primOpTag Word64EqOp = 159 +primOpTag Word64GeOp = 160 +primOpTag Word64GtOp = 161 +primOpTag Word64LeOp = 162 +primOpTag Word64LtOp = 163 +primOpTag Word64NeOp = 164 +primOpTag IntAddOp = 165 +primOpTag IntSubOp = 166 +primOpTag IntMulOp = 167 +primOpTag IntMul2Op = 168 +primOpTag IntMulMayOfloOp = 169 +primOpTag IntQuotOp = 170 +primOpTag IntRemOp = 171 +primOpTag IntQuotRemOp = 172 +primOpTag IntAndOp = 173 +primOpTag IntOrOp = 174 +primOpTag IntXorOp = 175 +primOpTag IntNotOp = 176 +primOpTag IntNegOp = 177 +primOpTag IntAddCOp = 178 +primOpTag IntSubCOp = 179 +primOpTag IntGtOp = 180 +primOpTag IntGeOp = 181 +primOpTag IntEqOp = 182 +primOpTag IntNeOp = 183 +primOpTag IntLtOp = 184 +primOpTag IntLeOp = 185 +primOpTag ChrOp = 186 +primOpTag IntToWordOp = 187 +primOpTag IntToFloatOp = 188 +primOpTag IntToDoubleOp = 189 +primOpTag WordToFloatOp = 190 +primOpTag WordToDoubleOp = 191 +primOpTag IntSllOp = 192 +primOpTag IntSraOp = 193 +primOpTag IntSrlOp = 194 +primOpTag WordAddOp = 195 +primOpTag WordAddCOp = 196 +primOpTag WordSubCOp = 197 +primOpTag WordAdd2Op = 198 +primOpTag WordSubOp = 199 +primOpTag WordMulOp = 200 +primOpTag WordMul2Op = 201 +primOpTag WordQuotOp = 202 +primOpTag WordRemOp = 203 +primOpTag WordQuotRemOp = 204 +primOpTag WordQuotRem2Op = 205 +primOpTag WordAndOp = 206 +primOpTag WordOrOp = 207 +primOpTag WordXorOp = 208 +primOpTag WordNotOp = 209 +primOpTag WordSllOp = 210 +primOpTag WordSrlOp = 211 +primOpTag WordToIntOp = 212 +primOpTag WordGtOp = 213 +primOpTag WordGeOp = 214 +primOpTag WordEqOp = 215 +primOpTag WordNeOp = 216 +primOpTag WordLtOp = 217 +primOpTag WordLeOp = 218 +primOpTag PopCnt8Op = 219 +primOpTag PopCnt16Op = 220 +primOpTag PopCnt32Op = 221 +primOpTag PopCnt64Op = 222 +primOpTag PopCntOp = 223 +primOpTag Pdep8Op = 224 +primOpTag Pdep16Op = 225 +primOpTag Pdep32Op = 226 +primOpTag Pdep64Op = 227 +primOpTag PdepOp = 228 +primOpTag Pext8Op = 229 +primOpTag Pext16Op = 230 +primOpTag Pext32Op = 231 +primOpTag Pext64Op = 232 +primOpTag PextOp = 233 +primOpTag Clz8Op = 234 +primOpTag Clz16Op = 235 +primOpTag Clz32Op = 236 +primOpTag Clz64Op = 237 +primOpTag ClzOp = 238 +primOpTag Ctz8Op = 239 +primOpTag Ctz16Op = 240 +primOpTag Ctz32Op = 241 +primOpTag Ctz64Op = 242 +primOpTag CtzOp = 243 +primOpTag BSwap16Op = 244 +primOpTag BSwap32Op = 245 +primOpTag BSwap64Op = 246 +primOpTag BSwapOp = 247 +primOpTag BRev8Op = 248 +primOpTag BRev16Op = 249 +primOpTag BRev32Op = 250 +primOpTag BRev64Op = 251 +primOpTag BRevOp = 252 +primOpTag Narrow8IntOp = 253 +primOpTag Narrow16IntOp = 254 +primOpTag Narrow32IntOp = 255 +primOpTag Narrow8WordOp = 256 +primOpTag Narrow16WordOp = 257 +primOpTag Narrow32WordOp = 258 +primOpTag DoubleGtOp = 259 +primOpTag DoubleGeOp = 260 +primOpTag DoubleEqOp = 261 +primOpTag DoubleNeOp = 262 +primOpTag DoubleLtOp = 263 +primOpTag DoubleLeOp = 264 +primOpTag DoubleAddOp = 265 +primOpTag DoubleSubOp = 266 +primOpTag DoubleMulOp = 267 +primOpTag DoubleDivOp = 268 +primOpTag DoubleNegOp = 269 +primOpTag DoubleFabsOp = 270 +primOpTag DoubleToIntOp = 271 +primOpTag DoubleToFloatOp = 272 +primOpTag DoubleExpOp = 273 +primOpTag DoubleExpM1Op = 274 +primOpTag DoubleLogOp = 275 +primOpTag DoubleLog1POp = 276 +primOpTag DoubleSqrtOp = 277 +primOpTag DoubleSinOp = 278 +primOpTag DoubleCosOp = 279 +primOpTag DoubleTanOp = 280 +primOpTag DoubleAsinOp = 281 +primOpTag DoubleAcosOp = 282 +primOpTag DoubleAtanOp = 283 +primOpTag DoubleSinhOp = 284 +primOpTag DoubleCoshOp = 285 +primOpTag DoubleTanhOp = 286 +primOpTag DoubleAsinhOp = 287 +primOpTag DoubleAcoshOp = 288 +primOpTag DoubleAtanhOp = 289 +primOpTag DoublePowerOp = 290 +primOpTag DoubleDecode_2IntOp = 291 +primOpTag DoubleDecode_Int64Op = 292 +primOpTag FloatGtOp = 293 +primOpTag FloatGeOp = 294 +primOpTag FloatEqOp = 295 +primOpTag FloatNeOp = 296 +primOpTag FloatLtOp = 297 +primOpTag FloatLeOp = 298 +primOpTag FloatAddOp = 299 +primOpTag FloatSubOp = 300 +primOpTag FloatMulOp = 301 +primOpTag FloatDivOp = 302 +primOpTag FloatNegOp = 303 +primOpTag FloatFabsOp = 304 +primOpTag FloatToIntOp = 305 +primOpTag FloatExpOp = 306 +primOpTag FloatExpM1Op = 307 +primOpTag FloatLogOp = 308 +primOpTag FloatLog1POp = 309 +primOpTag FloatSqrtOp = 310 +primOpTag FloatSinOp = 311 +primOpTag FloatCosOp = 312 +primOpTag FloatTanOp = 313 +primOpTag FloatAsinOp = 314 +primOpTag FloatAcosOp = 315 +primOpTag FloatAtanOp = 316 +primOpTag FloatSinhOp = 317 +primOpTag FloatCoshOp = 318 +primOpTag FloatTanhOp = 319 +primOpTag FloatAsinhOp = 320 +primOpTag FloatAcoshOp = 321 +primOpTag FloatAtanhOp = 322 +primOpTag FloatPowerOp = 323 +primOpTag FloatToDoubleOp = 324 +primOpTag FloatDecode_IntOp = 325 +primOpTag NewArrayOp = 326 +primOpTag ReadArrayOp = 327 +primOpTag WriteArrayOp = 328 +primOpTag SizeofArrayOp = 329 +primOpTag SizeofMutableArrayOp = 330 +primOpTag IndexArrayOp = 331 +primOpTag UnsafeFreezeArrayOp = 332 +primOpTag UnsafeThawArrayOp = 333 +primOpTag CopyArrayOp = 334 +primOpTag CopyMutableArrayOp = 335 +primOpTag CloneArrayOp = 336 +primOpTag CloneMutableArrayOp = 337 +primOpTag FreezeArrayOp = 338 +primOpTag ThawArrayOp = 339 +primOpTag CasArrayOp = 340 +primOpTag NewSmallArrayOp = 341 +primOpTag ShrinkSmallMutableArrayOp_Char = 342 +primOpTag ReadSmallArrayOp = 343 +primOpTag WriteSmallArrayOp = 344 +primOpTag SizeofSmallArrayOp = 345 +primOpTag SizeofSmallMutableArrayOp = 346 +primOpTag GetSizeofSmallMutableArrayOp = 347 +primOpTag IndexSmallArrayOp = 348 +primOpTag UnsafeFreezeSmallArrayOp = 349 +primOpTag UnsafeThawSmallArrayOp = 350 +primOpTag CopySmallArrayOp = 351 +primOpTag CopySmallMutableArrayOp = 352 +primOpTag CloneSmallArrayOp = 353 +primOpTag CloneSmallMutableArrayOp = 354 +primOpTag FreezeSmallArrayOp = 355 +primOpTag ThawSmallArrayOp = 356 +primOpTag CasSmallArrayOp = 357 +primOpTag NewByteArrayOp_Char = 358 +primOpTag NewPinnedByteArrayOp_Char = 359 +primOpTag NewAlignedPinnedByteArrayOp_Char = 360 +primOpTag MutableByteArrayIsPinnedOp = 361 +primOpTag ByteArrayIsPinnedOp = 362 +primOpTag ByteArrayContents_Char = 363 +primOpTag MutableByteArrayContents_Char = 364 +primOpTag ShrinkMutableByteArrayOp_Char = 365 +primOpTag ResizeMutableByteArrayOp_Char = 366 +primOpTag UnsafeFreezeByteArrayOp = 367 +primOpTag SizeofByteArrayOp = 368 +primOpTag SizeofMutableByteArrayOp = 369 +primOpTag GetSizeofMutableByteArrayOp = 370 +primOpTag IndexByteArrayOp_Char = 371 +primOpTag IndexByteArrayOp_WideChar = 372 +primOpTag IndexByteArrayOp_Int = 373 +primOpTag IndexByteArrayOp_Word = 374 +primOpTag IndexByteArrayOp_Addr = 375 +primOpTag IndexByteArrayOp_Float = 376 +primOpTag IndexByteArrayOp_Double = 377 +primOpTag IndexByteArrayOp_StablePtr = 378 +primOpTag IndexByteArrayOp_Int8 = 379 +primOpTag IndexByteArrayOp_Int16 = 380 +primOpTag IndexByteArrayOp_Int32 = 381 +primOpTag IndexByteArrayOp_Int64 = 382 +primOpTag IndexByteArrayOp_Word8 = 383 +primOpTag IndexByteArrayOp_Word16 = 384 +primOpTag IndexByteArrayOp_Word32 = 385 +primOpTag IndexByteArrayOp_Word64 = 386 +primOpTag IndexByteArrayOp_Word8AsChar = 387 +primOpTag IndexByteArrayOp_Word8AsWideChar = 388 +primOpTag IndexByteArrayOp_Word8AsInt = 389 +primOpTag IndexByteArrayOp_Word8AsWord = 390 +primOpTag IndexByteArrayOp_Word8AsAddr = 391 +primOpTag IndexByteArrayOp_Word8AsFloat = 392 +primOpTag IndexByteArrayOp_Word8AsDouble = 393 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 394 +primOpTag IndexByteArrayOp_Word8AsInt16 = 395 +primOpTag IndexByteArrayOp_Word8AsInt32 = 396 +primOpTag IndexByteArrayOp_Word8AsInt64 = 397 +primOpTag IndexByteArrayOp_Word8AsWord16 = 398 +primOpTag IndexByteArrayOp_Word8AsWord32 = 399 +primOpTag IndexByteArrayOp_Word8AsWord64 = 400 +primOpTag ReadByteArrayOp_Char = 401 +primOpTag ReadByteArrayOp_WideChar = 402 +primOpTag ReadByteArrayOp_Int = 403 +primOpTag ReadByteArrayOp_Word = 404 +primOpTag ReadByteArrayOp_Addr = 405 +primOpTag ReadByteArrayOp_Float = 406 +primOpTag ReadByteArrayOp_Double = 407 +primOpTag ReadByteArrayOp_StablePtr = 408 +primOpTag ReadByteArrayOp_Int8 = 409 +primOpTag ReadByteArrayOp_Int16 = 410 +primOpTag ReadByteArrayOp_Int32 = 411 +primOpTag ReadByteArrayOp_Int64 = 412 +primOpTag ReadByteArrayOp_Word8 = 413 +primOpTag ReadByteArrayOp_Word16 = 414 +primOpTag ReadByteArrayOp_Word32 = 415 +primOpTag ReadByteArrayOp_Word64 = 416 +primOpTag ReadByteArrayOp_Word8AsChar = 417 +primOpTag ReadByteArrayOp_Word8AsWideChar = 418 +primOpTag ReadByteArrayOp_Word8AsInt = 419 +primOpTag ReadByteArrayOp_Word8AsWord = 420 +primOpTag ReadByteArrayOp_Word8AsAddr = 421 +primOpTag ReadByteArrayOp_Word8AsFloat = 422 +primOpTag ReadByteArrayOp_Word8AsDouble = 423 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 424 +primOpTag ReadByteArrayOp_Word8AsInt16 = 425 +primOpTag ReadByteArrayOp_Word8AsInt32 = 426 +primOpTag ReadByteArrayOp_Word8AsInt64 = 427 +primOpTag ReadByteArrayOp_Word8AsWord16 = 428 +primOpTag ReadByteArrayOp_Word8AsWord32 = 429 +primOpTag ReadByteArrayOp_Word8AsWord64 = 430 +primOpTag WriteByteArrayOp_Char = 431 +primOpTag WriteByteArrayOp_WideChar = 432 +primOpTag WriteByteArrayOp_Int = 433 +primOpTag WriteByteArrayOp_Word = 434 +primOpTag WriteByteArrayOp_Addr = 435 +primOpTag WriteByteArrayOp_Float = 436 +primOpTag WriteByteArrayOp_Double = 437 +primOpTag WriteByteArrayOp_StablePtr = 438 +primOpTag WriteByteArrayOp_Int8 = 439 +primOpTag WriteByteArrayOp_Int16 = 440 +primOpTag WriteByteArrayOp_Int32 = 441 +primOpTag WriteByteArrayOp_Int64 = 442 +primOpTag WriteByteArrayOp_Word8 = 443 +primOpTag WriteByteArrayOp_Word16 = 444 +primOpTag WriteByteArrayOp_Word32 = 445 +primOpTag WriteByteArrayOp_Word64 = 446 +primOpTag WriteByteArrayOp_Word8AsChar = 447 +primOpTag WriteByteArrayOp_Word8AsWideChar = 448 +primOpTag WriteByteArrayOp_Word8AsInt = 449 +primOpTag WriteByteArrayOp_Word8AsWord = 450 +primOpTag WriteByteArrayOp_Word8AsAddr = 451 +primOpTag WriteByteArrayOp_Word8AsFloat = 452 +primOpTag WriteByteArrayOp_Word8AsDouble = 453 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 454 +primOpTag WriteByteArrayOp_Word8AsInt16 = 455 +primOpTag WriteByteArrayOp_Word8AsInt32 = 456 +primOpTag WriteByteArrayOp_Word8AsInt64 = 457 +primOpTag WriteByteArrayOp_Word8AsWord16 = 458 +primOpTag WriteByteArrayOp_Word8AsWord32 = 459 +primOpTag WriteByteArrayOp_Word8AsWord64 = 460 +primOpTag CompareByteArraysOp = 461 +primOpTag CopyByteArrayOp = 462 +primOpTag CopyMutableByteArrayOp = 463 +primOpTag CopyByteArrayToAddrOp = 464 +primOpTag CopyMutableByteArrayToAddrOp = 465 +primOpTag CopyAddrToByteArrayOp = 466 +primOpTag SetByteArrayOp = 467 +primOpTag AtomicReadByteArrayOp_Int = 468 +primOpTag AtomicWriteByteArrayOp_Int = 469 +primOpTag CasByteArrayOp_Int = 470 +primOpTag CasByteArrayOp_Int8 = 471 +primOpTag CasByteArrayOp_Int16 = 472 +primOpTag CasByteArrayOp_Int32 = 473 +primOpTag CasByteArrayOp_Int64 = 474 +primOpTag FetchAddByteArrayOp_Int = 475 +primOpTag FetchSubByteArrayOp_Int = 476 +primOpTag FetchAndByteArrayOp_Int = 477 +primOpTag FetchNandByteArrayOp_Int = 478 +primOpTag FetchOrByteArrayOp_Int = 479 +primOpTag FetchXorByteArrayOp_Int = 480 +primOpTag AddrAddOp = 481 +primOpTag AddrSubOp = 482 +primOpTag AddrRemOp = 483 +primOpTag AddrToIntOp = 484 +primOpTag IntToAddrOp = 485 +primOpTag AddrGtOp = 486 +primOpTag AddrGeOp = 487 +primOpTag AddrEqOp = 488 +primOpTag AddrNeOp = 489 +primOpTag AddrLtOp = 490 +primOpTag AddrLeOp = 491 +primOpTag IndexOffAddrOp_Char = 492 +primOpTag IndexOffAddrOp_WideChar = 493 +primOpTag IndexOffAddrOp_Int = 494 +primOpTag IndexOffAddrOp_Word = 495 +primOpTag IndexOffAddrOp_Addr = 496 +primOpTag IndexOffAddrOp_Float = 497 +primOpTag IndexOffAddrOp_Double = 498 +primOpTag IndexOffAddrOp_StablePtr = 499 +primOpTag IndexOffAddrOp_Int8 = 500 +primOpTag IndexOffAddrOp_Int16 = 501 +primOpTag IndexOffAddrOp_Int32 = 502 +primOpTag IndexOffAddrOp_Int64 = 503 +primOpTag IndexOffAddrOp_Word8 = 504 +primOpTag IndexOffAddrOp_Word16 = 505 +primOpTag IndexOffAddrOp_Word32 = 506 +primOpTag IndexOffAddrOp_Word64 = 507 +primOpTag ReadOffAddrOp_Char = 508 +primOpTag ReadOffAddrOp_WideChar = 509 +primOpTag ReadOffAddrOp_Int = 510 +primOpTag ReadOffAddrOp_Word = 511 +primOpTag ReadOffAddrOp_Addr = 512 +primOpTag ReadOffAddrOp_Float = 513 +primOpTag ReadOffAddrOp_Double = 514 +primOpTag ReadOffAddrOp_StablePtr = 515 +primOpTag ReadOffAddrOp_Int8 = 516 +primOpTag ReadOffAddrOp_Int16 = 517 +primOpTag ReadOffAddrOp_Int32 = 518 +primOpTag ReadOffAddrOp_Int64 = 519 +primOpTag ReadOffAddrOp_Word8 = 520 +primOpTag ReadOffAddrOp_Word16 = 521 +primOpTag ReadOffAddrOp_Word32 = 522 +primOpTag ReadOffAddrOp_Word64 = 523 +primOpTag WriteOffAddrOp_Char = 524 +primOpTag WriteOffAddrOp_WideChar = 525 +primOpTag WriteOffAddrOp_Int = 526 +primOpTag WriteOffAddrOp_Word = 527 +primOpTag WriteOffAddrOp_Addr = 528 +primOpTag WriteOffAddrOp_Float = 529 +primOpTag WriteOffAddrOp_Double = 530 +primOpTag WriteOffAddrOp_StablePtr = 531 +primOpTag WriteOffAddrOp_Int8 = 532 +primOpTag WriteOffAddrOp_Int16 = 533 +primOpTag WriteOffAddrOp_Int32 = 534 +primOpTag WriteOffAddrOp_Int64 = 535 +primOpTag WriteOffAddrOp_Word8 = 536 +primOpTag WriteOffAddrOp_Word16 = 537 +primOpTag WriteOffAddrOp_Word32 = 538 +primOpTag WriteOffAddrOp_Word64 = 539 +primOpTag InterlockedExchange_Addr = 540 +primOpTag InterlockedExchange_Word = 541 +primOpTag CasAddrOp_Addr = 542 +primOpTag CasAddrOp_Word = 543 +primOpTag CasAddrOp_Word8 = 544 +primOpTag CasAddrOp_Word16 = 545 +primOpTag CasAddrOp_Word32 = 546 +primOpTag CasAddrOp_Word64 = 547 +primOpTag FetchAddAddrOp_Word = 548 +primOpTag FetchSubAddrOp_Word = 549 +primOpTag FetchAndAddrOp_Word = 550 +primOpTag FetchNandAddrOp_Word = 551 +primOpTag FetchOrAddrOp_Word = 552 +primOpTag FetchXorAddrOp_Word = 553 +primOpTag AtomicReadAddrOp_Word = 554 +primOpTag AtomicWriteAddrOp_Word = 555 +primOpTag NewMutVarOp = 556 +primOpTag ReadMutVarOp = 557 +primOpTag WriteMutVarOp = 558 +primOpTag AtomicModifyMutVar2Op = 559 +primOpTag AtomicModifyMutVar_Op = 560 +primOpTag CasMutVarOp = 561 +primOpTag CatchOp = 562 +primOpTag RaiseOp = 563 +primOpTag RaiseIOOp = 564 +primOpTag MaskAsyncExceptionsOp = 565 +primOpTag MaskUninterruptibleOp = 566 +primOpTag UnmaskAsyncExceptionsOp = 567 +primOpTag MaskStatus = 568 +primOpTag AtomicallyOp = 569 +primOpTag RetryOp = 570 +primOpTag CatchRetryOp = 571 +primOpTag CatchSTMOp = 572 +primOpTag NewTVarOp = 573 +primOpTag ReadTVarOp = 574 +primOpTag ReadTVarIOOp = 575 +primOpTag WriteTVarOp = 576 +primOpTag NewMVarOp = 577 +primOpTag TakeMVarOp = 578 +primOpTag TryTakeMVarOp = 579 +primOpTag PutMVarOp = 580 +primOpTag TryPutMVarOp = 581 +primOpTag ReadMVarOp = 582 +primOpTag TryReadMVarOp = 583 +primOpTag IsEmptyMVarOp = 584 +primOpTag NewIOPortOp = 585 +primOpTag ReadIOPortOp = 586 +primOpTag WriteIOPortOp = 587 +primOpTag DelayOp = 588 +primOpTag WaitReadOp = 589 +primOpTag WaitWriteOp = 590 +primOpTag ForkOp = 591 +primOpTag ForkOnOp = 592 +primOpTag KillThreadOp = 593 +primOpTag YieldOp = 594 +primOpTag MyThreadIdOp = 595 +primOpTag LabelThreadOp = 596 +primOpTag IsCurrentThreadBoundOp = 597 +primOpTag NoDuplicateOp = 598 +primOpTag ThreadStatusOp = 599 +primOpTag MkWeakOp = 600 +primOpTag MkWeakNoFinalizerOp = 601 +primOpTag AddCFinalizerToWeakOp = 602 +primOpTag DeRefWeakOp = 603 +primOpTag FinalizeWeakOp = 604 +primOpTag TouchOp = 605 +primOpTag MakeStablePtrOp = 606 +primOpTag DeRefStablePtrOp = 607 +primOpTag EqStablePtrOp = 608 +primOpTag MakeStableNameOp = 609 +primOpTag StableNameToIntOp = 610 +primOpTag CompactNewOp = 611 +primOpTag CompactResizeOp = 612 +primOpTag CompactContainsOp = 613 +primOpTag CompactContainsAnyOp = 614 +primOpTag CompactGetFirstBlockOp = 615 +primOpTag CompactGetNextBlockOp = 616 +primOpTag CompactAllocateBlockOp = 617 +primOpTag CompactFixupPointersOp = 618 +primOpTag CompactAdd = 619 +primOpTag CompactAddWithSharing = 620 +primOpTag CompactSize = 621 +primOpTag ReallyUnsafePtrEqualityOp = 622 +primOpTag ParOp = 623 +primOpTag SparkOp = 624 +primOpTag SeqOp = 625 +primOpTag GetSparkOp = 626 +primOpTag NumSparks = 627 +primOpTag KeepAliveOp = 628 +primOpTag DataToTagOp = 629 +primOpTag TagToEnumOp = 630 +primOpTag AddrToAnyOp = 631 +primOpTag AnyToAddrOp = 632 +primOpTag MkApUpd0_Op = 633 +primOpTag NewBCOOp = 634 +primOpTag UnpackClosureOp = 635 +primOpTag ClosureSizeOp = 636 +primOpTag GetApStackValOp = 637 +primOpTag GetCCSOfOp = 638 +primOpTag GetCurrentCCSOp = 639 +primOpTag ClearCCSOp = 640 +primOpTag WhereFromOp = 641 +primOpTag TraceEventOp = 642 +primOpTag TraceEventBinaryOp = 643 +primOpTag TraceMarkerOp = 644 +primOpTag SetThreadAllocationCounter = 645 +primOpTag (VecBroadcastOp IntVec 16 W8) = 646 +primOpTag (VecBroadcastOp IntVec 8 W16) = 647 +primOpTag (VecBroadcastOp IntVec 4 W32) = 648 +primOpTag (VecBroadcastOp IntVec 2 W64) = 649 +primOpTag (VecBroadcastOp IntVec 32 W8) = 650 +primOpTag (VecBroadcastOp IntVec 16 W16) = 651 +primOpTag (VecBroadcastOp IntVec 8 W32) = 652 +primOpTag (VecBroadcastOp IntVec 4 W64) = 653 +primOpTag (VecBroadcastOp IntVec 64 W8) = 654 +primOpTag (VecBroadcastOp IntVec 32 W16) = 655 +primOpTag (VecBroadcastOp IntVec 16 W32) = 656 +primOpTag (VecBroadcastOp IntVec 8 W64) = 657 +primOpTag (VecBroadcastOp WordVec 16 W8) = 658 +primOpTag (VecBroadcastOp WordVec 8 W16) = 659 +primOpTag (VecBroadcastOp WordVec 4 W32) = 660 +primOpTag (VecBroadcastOp WordVec 2 W64) = 661 +primOpTag (VecBroadcastOp WordVec 32 W8) = 662 +primOpTag (VecBroadcastOp WordVec 16 W16) = 663 +primOpTag (VecBroadcastOp WordVec 8 W32) = 664 +primOpTag (VecBroadcastOp WordVec 4 W64) = 665 +primOpTag (VecBroadcastOp WordVec 64 W8) = 666 +primOpTag (VecBroadcastOp WordVec 32 W16) = 667 +primOpTag (VecBroadcastOp WordVec 16 W32) = 668 +primOpTag (VecBroadcastOp WordVec 8 W64) = 669 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 670 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 671 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 672 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 673 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 674 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 675 +primOpTag (VecPackOp IntVec 16 W8) = 676 +primOpTag (VecPackOp IntVec 8 W16) = 677 +primOpTag (VecPackOp IntVec 4 W32) = 678 +primOpTag (VecPackOp IntVec 2 W64) = 679 +primOpTag (VecPackOp IntVec 32 W8) = 680 +primOpTag (VecPackOp IntVec 16 W16) = 681 +primOpTag (VecPackOp IntVec 8 W32) = 682 +primOpTag (VecPackOp IntVec 4 W64) = 683 +primOpTag (VecPackOp IntVec 64 W8) = 684 +primOpTag (VecPackOp IntVec 32 W16) = 685 +primOpTag (VecPackOp IntVec 16 W32) = 686 +primOpTag (VecPackOp IntVec 8 W64) = 687 +primOpTag (VecPackOp WordVec 16 W8) = 688 +primOpTag (VecPackOp WordVec 8 W16) = 689 +primOpTag (VecPackOp WordVec 4 W32) = 690 +primOpTag (VecPackOp WordVec 2 W64) = 691 +primOpTag (VecPackOp WordVec 32 W8) = 692 +primOpTag (VecPackOp WordVec 16 W16) = 693 +primOpTag (VecPackOp WordVec 8 W32) = 694 +primOpTag (VecPackOp WordVec 4 W64) = 695 +primOpTag (VecPackOp WordVec 64 W8) = 696 +primOpTag (VecPackOp WordVec 32 W16) = 697 +primOpTag (VecPackOp WordVec 16 W32) = 698 +primOpTag (VecPackOp WordVec 8 W64) = 699 +primOpTag (VecPackOp FloatVec 4 W32) = 700 +primOpTag (VecPackOp FloatVec 2 W64) = 701 +primOpTag (VecPackOp FloatVec 8 W32) = 702 +primOpTag (VecPackOp FloatVec 4 W64) = 703 +primOpTag (VecPackOp FloatVec 16 W32) = 704 +primOpTag (VecPackOp FloatVec 8 W64) = 705 +primOpTag (VecUnpackOp IntVec 16 W8) = 706 +primOpTag (VecUnpackOp IntVec 8 W16) = 707 +primOpTag (VecUnpackOp IntVec 4 W32) = 708 +primOpTag (VecUnpackOp IntVec 2 W64) = 709 +primOpTag (VecUnpackOp IntVec 32 W8) = 710 +primOpTag (VecUnpackOp IntVec 16 W16) = 711 +primOpTag (VecUnpackOp IntVec 8 W32) = 712 +primOpTag (VecUnpackOp IntVec 4 W64) = 713 +primOpTag (VecUnpackOp IntVec 64 W8) = 714 +primOpTag (VecUnpackOp IntVec 32 W16) = 715 +primOpTag (VecUnpackOp IntVec 16 W32) = 716 +primOpTag (VecUnpackOp IntVec 8 W64) = 717 +primOpTag (VecUnpackOp WordVec 16 W8) = 718 +primOpTag (VecUnpackOp WordVec 8 W16) = 719 +primOpTag (VecUnpackOp WordVec 4 W32) = 720 +primOpTag (VecUnpackOp WordVec 2 W64) = 721 +primOpTag (VecUnpackOp WordVec 32 W8) = 722 +primOpTag (VecUnpackOp WordVec 16 W16) = 723 +primOpTag (VecUnpackOp WordVec 8 W32) = 724 +primOpTag (VecUnpackOp WordVec 4 W64) = 725 +primOpTag (VecUnpackOp WordVec 64 W8) = 726 +primOpTag (VecUnpackOp WordVec 32 W16) = 727 +primOpTag (VecUnpackOp WordVec 16 W32) = 728 +primOpTag (VecUnpackOp WordVec 8 W64) = 729 +primOpTag (VecUnpackOp FloatVec 4 W32) = 730 +primOpTag (VecUnpackOp FloatVec 2 W64) = 731 +primOpTag (VecUnpackOp FloatVec 8 W32) = 732 +primOpTag (VecUnpackOp FloatVec 4 W64) = 733 +primOpTag (VecUnpackOp FloatVec 16 W32) = 734 +primOpTag (VecUnpackOp FloatVec 8 W64) = 735 +primOpTag (VecInsertOp IntVec 16 W8) = 736 +primOpTag (VecInsertOp IntVec 8 W16) = 737 +primOpTag (VecInsertOp IntVec 4 W32) = 738 +primOpTag (VecInsertOp IntVec 2 W64) = 739 +primOpTag (VecInsertOp IntVec 32 W8) = 740 +primOpTag (VecInsertOp IntVec 16 W16) = 741 +primOpTag (VecInsertOp IntVec 8 W32) = 742 +primOpTag (VecInsertOp IntVec 4 W64) = 743 +primOpTag (VecInsertOp IntVec 64 W8) = 744 +primOpTag (VecInsertOp IntVec 32 W16) = 745 +primOpTag (VecInsertOp IntVec 16 W32) = 746 +primOpTag (VecInsertOp IntVec 8 W64) = 747 +primOpTag (VecInsertOp WordVec 16 W8) = 748 +primOpTag (VecInsertOp WordVec 8 W16) = 749 +primOpTag (VecInsertOp WordVec 4 W32) = 750 +primOpTag (VecInsertOp WordVec 2 W64) = 751 +primOpTag (VecInsertOp WordVec 32 W8) = 752 +primOpTag (VecInsertOp WordVec 16 W16) = 753 +primOpTag (VecInsertOp WordVec 8 W32) = 754 +primOpTag (VecInsertOp WordVec 4 W64) = 755 +primOpTag (VecInsertOp WordVec 64 W8) = 756 +primOpTag (VecInsertOp WordVec 32 W16) = 757 +primOpTag (VecInsertOp WordVec 16 W32) = 758 +primOpTag (VecInsertOp WordVec 8 W64) = 759 +primOpTag (VecInsertOp FloatVec 4 W32) = 760 +primOpTag (VecInsertOp FloatVec 2 W64) = 761 +primOpTag (VecInsertOp FloatVec 8 W32) = 762 +primOpTag (VecInsertOp FloatVec 4 W64) = 763 +primOpTag (VecInsertOp FloatVec 16 W32) = 764 +primOpTag (VecInsertOp FloatVec 8 W64) = 765 +primOpTag (VecAddOp IntVec 16 W8) = 766 +primOpTag (VecAddOp IntVec 8 W16) = 767 +primOpTag (VecAddOp IntVec 4 W32) = 768 +primOpTag (VecAddOp IntVec 2 W64) = 769 +primOpTag (VecAddOp IntVec 32 W8) = 770 +primOpTag (VecAddOp IntVec 16 W16) = 771 +primOpTag (VecAddOp IntVec 8 W32) = 772 +primOpTag (VecAddOp IntVec 4 W64) = 773 +primOpTag (VecAddOp IntVec 64 W8) = 774 +primOpTag (VecAddOp IntVec 32 W16) = 775 +primOpTag (VecAddOp IntVec 16 W32) = 776 +primOpTag (VecAddOp IntVec 8 W64) = 777 +primOpTag (VecAddOp WordVec 16 W8) = 778 +primOpTag (VecAddOp WordVec 8 W16) = 779 +primOpTag (VecAddOp WordVec 4 W32) = 780 +primOpTag (VecAddOp WordVec 2 W64) = 781 +primOpTag (VecAddOp WordVec 32 W8) = 782 +primOpTag (VecAddOp WordVec 16 W16) = 783 +primOpTag (VecAddOp WordVec 8 W32) = 784 +primOpTag (VecAddOp WordVec 4 W64) = 785 +primOpTag (VecAddOp WordVec 64 W8) = 786 +primOpTag (VecAddOp WordVec 32 W16) = 787 +primOpTag (VecAddOp WordVec 16 W32) = 788 +primOpTag (VecAddOp WordVec 8 W64) = 789 +primOpTag (VecAddOp FloatVec 4 W32) = 790 +primOpTag (VecAddOp FloatVec 2 W64) = 791 +primOpTag (VecAddOp FloatVec 8 W32) = 792 +primOpTag (VecAddOp FloatVec 4 W64) = 793 +primOpTag (VecAddOp FloatVec 16 W32) = 794 +primOpTag (VecAddOp FloatVec 8 W64) = 795 +primOpTag (VecSubOp IntVec 16 W8) = 796 +primOpTag (VecSubOp IntVec 8 W16) = 797 +primOpTag (VecSubOp IntVec 4 W32) = 798 +primOpTag (VecSubOp IntVec 2 W64) = 799 +primOpTag (VecSubOp IntVec 32 W8) = 800 +primOpTag (VecSubOp IntVec 16 W16) = 801 +primOpTag (VecSubOp IntVec 8 W32) = 802 +primOpTag (VecSubOp IntVec 4 W64) = 803 +primOpTag (VecSubOp IntVec 64 W8) = 804 +primOpTag (VecSubOp IntVec 32 W16) = 805 +primOpTag (VecSubOp IntVec 16 W32) = 806 +primOpTag (VecSubOp IntVec 8 W64) = 807 +primOpTag (VecSubOp WordVec 16 W8) = 808 +primOpTag (VecSubOp WordVec 8 W16) = 809 +primOpTag (VecSubOp WordVec 4 W32) = 810 +primOpTag (VecSubOp WordVec 2 W64) = 811 +primOpTag (VecSubOp WordVec 32 W8) = 812 +primOpTag (VecSubOp WordVec 16 W16) = 813 +primOpTag (VecSubOp WordVec 8 W32) = 814 +primOpTag (VecSubOp WordVec 4 W64) = 815 +primOpTag (VecSubOp WordVec 64 W8) = 816 +primOpTag (VecSubOp WordVec 32 W16) = 817 +primOpTag (VecSubOp WordVec 16 W32) = 818 +primOpTag (VecSubOp WordVec 8 W64) = 819 +primOpTag (VecSubOp FloatVec 4 W32) = 820 +primOpTag (VecSubOp FloatVec 2 W64) = 821 +primOpTag (VecSubOp FloatVec 8 W32) = 822 +primOpTag (VecSubOp FloatVec 4 W64) = 823 +primOpTag (VecSubOp FloatVec 16 W32) = 824 +primOpTag (VecSubOp FloatVec 8 W64) = 825 +primOpTag (VecMulOp IntVec 16 W8) = 826 +primOpTag (VecMulOp IntVec 8 W16) = 827 +primOpTag (VecMulOp IntVec 4 W32) = 828 +primOpTag (VecMulOp IntVec 2 W64) = 829 +primOpTag (VecMulOp IntVec 32 W8) = 830 +primOpTag (VecMulOp IntVec 16 W16) = 831 +primOpTag (VecMulOp IntVec 8 W32) = 832 +primOpTag (VecMulOp IntVec 4 W64) = 833 +primOpTag (VecMulOp IntVec 64 W8) = 834 +primOpTag (VecMulOp IntVec 32 W16) = 835 +primOpTag (VecMulOp IntVec 16 W32) = 836 +primOpTag (VecMulOp IntVec 8 W64) = 837 +primOpTag (VecMulOp WordVec 16 W8) = 838 +primOpTag (VecMulOp WordVec 8 W16) = 839 +primOpTag (VecMulOp WordVec 4 W32) = 840 +primOpTag (VecMulOp WordVec 2 W64) = 841 +primOpTag (VecMulOp WordVec 32 W8) = 842 +primOpTag (VecMulOp WordVec 16 W16) = 843 +primOpTag (VecMulOp WordVec 8 W32) = 844 +primOpTag (VecMulOp WordVec 4 W64) = 845 +primOpTag (VecMulOp WordVec 64 W8) = 846 +primOpTag (VecMulOp WordVec 32 W16) = 847 +primOpTag (VecMulOp WordVec 16 W32) = 848 +primOpTag (VecMulOp WordVec 8 W64) = 849 +primOpTag (VecMulOp FloatVec 4 W32) = 850 +primOpTag (VecMulOp FloatVec 2 W64) = 851 +primOpTag (VecMulOp FloatVec 8 W32) = 852 +primOpTag (VecMulOp FloatVec 4 W64) = 853 +primOpTag (VecMulOp FloatVec 16 W32) = 854 +primOpTag (VecMulOp FloatVec 8 W64) = 855 +primOpTag (VecDivOp FloatVec 4 W32) = 856 +primOpTag (VecDivOp FloatVec 2 W64) = 857 +primOpTag (VecDivOp FloatVec 8 W32) = 858 +primOpTag (VecDivOp FloatVec 4 W64) = 859 +primOpTag (VecDivOp FloatVec 16 W32) = 860 +primOpTag (VecDivOp FloatVec 8 W64) = 861 +primOpTag (VecQuotOp IntVec 16 W8) = 862 +primOpTag (VecQuotOp IntVec 8 W16) = 863 +primOpTag (VecQuotOp IntVec 4 W32) = 864 +primOpTag (VecQuotOp IntVec 2 W64) = 865 +primOpTag (VecQuotOp IntVec 32 W8) = 866 +primOpTag (VecQuotOp IntVec 16 W16) = 867 +primOpTag (VecQuotOp IntVec 8 W32) = 868 +primOpTag (VecQuotOp IntVec 4 W64) = 869 +primOpTag (VecQuotOp IntVec 64 W8) = 870 +primOpTag (VecQuotOp IntVec 32 W16) = 871 +primOpTag (VecQuotOp IntVec 16 W32) = 872 +primOpTag (VecQuotOp IntVec 8 W64) = 873 +primOpTag (VecQuotOp WordVec 16 W8) = 874 +primOpTag (VecQuotOp WordVec 8 W16) = 875 +primOpTag (VecQuotOp WordVec 4 W32) = 876 +primOpTag (VecQuotOp WordVec 2 W64) = 877 +primOpTag (VecQuotOp WordVec 32 W8) = 878 +primOpTag (VecQuotOp WordVec 16 W16) = 879 +primOpTag (VecQuotOp WordVec 8 W32) = 880 +primOpTag (VecQuotOp WordVec 4 W64) = 881 +primOpTag (VecQuotOp WordVec 64 W8) = 882 +primOpTag (VecQuotOp WordVec 32 W16) = 883 +primOpTag (VecQuotOp WordVec 16 W32) = 884 +primOpTag (VecQuotOp WordVec 8 W64) = 885 +primOpTag (VecRemOp IntVec 16 W8) = 886 +primOpTag (VecRemOp IntVec 8 W16) = 887 +primOpTag (VecRemOp IntVec 4 W32) = 888 +primOpTag (VecRemOp IntVec 2 W64) = 889 +primOpTag (VecRemOp IntVec 32 W8) = 890 +primOpTag (VecRemOp IntVec 16 W16) = 891 +primOpTag (VecRemOp IntVec 8 W32) = 892 +primOpTag (VecRemOp IntVec 4 W64) = 893 +primOpTag (VecRemOp IntVec 64 W8) = 894 +primOpTag (VecRemOp IntVec 32 W16) = 895 +primOpTag (VecRemOp IntVec 16 W32) = 896 +primOpTag (VecRemOp IntVec 8 W64) = 897 +primOpTag (VecRemOp WordVec 16 W8) = 898 +primOpTag (VecRemOp WordVec 8 W16) = 899 +primOpTag (VecRemOp WordVec 4 W32) = 900 +primOpTag (VecRemOp WordVec 2 W64) = 901 +primOpTag (VecRemOp WordVec 32 W8) = 902 +primOpTag (VecRemOp WordVec 16 W16) = 903 +primOpTag (VecRemOp WordVec 8 W32) = 904 +primOpTag (VecRemOp WordVec 4 W64) = 905 +primOpTag (VecRemOp WordVec 64 W8) = 906 +primOpTag (VecRemOp WordVec 32 W16) = 907 +primOpTag (VecRemOp WordVec 16 W32) = 908 +primOpTag (VecRemOp WordVec 8 W64) = 909 +primOpTag (VecNegOp IntVec 16 W8) = 910 +primOpTag (VecNegOp IntVec 8 W16) = 911 +primOpTag (VecNegOp IntVec 4 W32) = 912 +primOpTag (VecNegOp IntVec 2 W64) = 913 +primOpTag (VecNegOp IntVec 32 W8) = 914 +primOpTag (VecNegOp IntVec 16 W16) = 915 +primOpTag (VecNegOp IntVec 8 W32) = 916 +primOpTag (VecNegOp IntVec 4 W64) = 917 +primOpTag (VecNegOp IntVec 64 W8) = 918 +primOpTag (VecNegOp IntVec 32 W16) = 919 +primOpTag (VecNegOp IntVec 16 W32) = 920 +primOpTag (VecNegOp IntVec 8 W64) = 921 +primOpTag (VecNegOp FloatVec 4 W32) = 922 +primOpTag (VecNegOp FloatVec 2 W64) = 923 +primOpTag (VecNegOp FloatVec 8 W32) = 924 +primOpTag (VecNegOp FloatVec 4 W64) = 925 +primOpTag (VecNegOp FloatVec 16 W32) = 926 +primOpTag (VecNegOp FloatVec 8 W64) = 927 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 928 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 929 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 930 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 931 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 932 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 933 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 934 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 935 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 936 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 937 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 938 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 939 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 940 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 941 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 942 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 943 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 944 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 945 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 946 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 947 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 948 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 949 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 950 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 951 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 952 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 953 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 954 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 955 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 956 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 957 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 958 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 959 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 960 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 961 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 962 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 963 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 964 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 965 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 966 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 967 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 968 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 969 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 970 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 971 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 972 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 973 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 974 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 975 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 976 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 977 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 978 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 979 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 980 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 981 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 982 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 983 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 984 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 985 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 986 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 987 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 988 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 989 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 990 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 991 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 992 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 993 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 994 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 995 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 996 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 997 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 998 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 999 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1000 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1001 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1002 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1003 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1004 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1005 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1006 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1007 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1008 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1009 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1010 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1011 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1012 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1013 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1014 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1015 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1016 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1017 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1018 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1019 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1020 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1021 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1022 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1023 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1024 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1025 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1026 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1027 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1028 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1029 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1030 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1031 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1032 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1033 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1034 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1035 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1036 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1037 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1038 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1039 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1040 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1041 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1042 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1043 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1044 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1045 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1046 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1047 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1048 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1049 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1050 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1051 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1052 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1053 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1054 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1055 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1056 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1057 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1058 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1059 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1060 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1061 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1062 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1063 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1064 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1065 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1066 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1067 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1068 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1069 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1070 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1071 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1072 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1073 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1074 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1075 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1076 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1077 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1078 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1079 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1080 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1081 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1082 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1083 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1084 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1085 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1086 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1087 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1088 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1089 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1090 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1091 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1092 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1093 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1094 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1095 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1096 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1097 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1098 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1099 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1100 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1101 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1102 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1103 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1104 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1105 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1106 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1107 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1108 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1109 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1110 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1111 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1112 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1113 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1114 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1115 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1116 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1117 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1118 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1119 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1120 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1121 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1122 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1123 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1124 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1125 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1126 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1127 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1128 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1129 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1130 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1131 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1132 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1133 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1134 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1135 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1136 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1137 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1138 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1139 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1140 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1141 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1142 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1143 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1144 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1145 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1146 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1147 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1148 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1149 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1150 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1151 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1152 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1153 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1154 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1155 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1156 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1157 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1158 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1159 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1160 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1161 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1162 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1163 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1164 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1165 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1166 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1167 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1168 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1169 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1170 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1171 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1172 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1173 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1174 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1175 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1176 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1177 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1178 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1179 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1180 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1181 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1182 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1183 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1184 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1185 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1186 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1187 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1188 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1189 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1190 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1191 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1192 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1193 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1194 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1195 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1196 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1197 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1198 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1199 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1200 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1201 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1202 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1203 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1204 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1205 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1206 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1207 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1208 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1209 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1210 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1211 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1212 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1213 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1214 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1215 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1216 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1217 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1218 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1219 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1220 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1221 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1222 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1223 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1224 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1225 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1226 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1227 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1228 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1229 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1230 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1231 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1232 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1233 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1234 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1235 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1236 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1237 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1238 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1239 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1240 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1241 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1242 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1243 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1244 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1245 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1246 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1247 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1248 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1249 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1250 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1251 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1252 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1253 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1254 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1255 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1256 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1257 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1258 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1259 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1260 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1261 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1262 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1263 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1264 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1265 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1266 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1267 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1268 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1269 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1270 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1271 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1272 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1273 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1274 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1275 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1276 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1277 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1278 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1279 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1280 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1281 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1282 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1283 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1284 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1285 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1286 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1287 +primOpTag PrefetchByteArrayOp3 = 1288 +primOpTag PrefetchMutableByteArrayOp3 = 1289 +primOpTag PrefetchAddrOp3 = 1290 +primOpTag PrefetchValueOp3 = 1291 +primOpTag PrefetchByteArrayOp2 = 1292 +primOpTag PrefetchMutableByteArrayOp2 = 1293 +primOpTag PrefetchAddrOp2 = 1294 +primOpTag PrefetchValueOp2 = 1295 +primOpTag PrefetchByteArrayOp1 = 1296 +primOpTag PrefetchMutableByteArrayOp1 = 1297 +primOpTag PrefetchAddrOp1 = 1298 +primOpTag PrefetchValueOp1 = 1299 +primOpTag PrefetchByteArrayOp0 = 1300 +primOpTag PrefetchMutableByteArrayOp0 = 1301 +primOpTag PrefetchAddrOp0 = 1302 +primOpTag PrefetchValueOp0 = 1303 diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -113,6 +113,10 @@ don't. */ #define HAVE_DECL_CTIME_R 1 +/* Define to 1 if you have the declaration of `environ', and to 0 if you + don't. */ +#define HAVE_DECL_ENVIRON 0 + /* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */ diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -67,28 +67,6 @@ mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes mkJumpToAddr a = case hostPlatformArch of - ArchSPARC -> pure $ - -- After some consideration, we'll try this, where - -- 0x55555555 stands in for the address to jump to. - -- According to rts/include/rts/MachRegs.h, %g3 is very - -- likely indeed to be baggable. - -- - -- 0000 07155555 sethi %hi(0x55555555), %g3 - -- 0004 8610E155 or %g3, %lo(0x55555555), %g3 - -- 0008 81C0C000 jmp %g3 - -- 000c 01000000 nop - - let w32 = fromIntegral (funPtrToInt a) - - hi22, lo10 :: Word32 -> Word32 - lo10 x = x .&. 0x3FF - hi22 x = (x `shiftR` 10) .&. 0x3FFFF - - in Right [ 0x07000000 .|. (hi22 w32), - 0x8610E000 .|. (lo10 w32), - 0x81C0C000, - 0x01000000 ] - ArchPPC -> pure $ -- We'll use r12, for no particular reason. -- 0xDEADBEEF stands for the address: