ghc 9.2.3.20220620 → 9.2.4
raw patch · 38 files changed
+930/−322 lines, 38 filesdep ~ghc-bootdep ~ghc-heapdep ~ghci
Dependency ranges changed: ghc-boot, ghc-heap, ghci
Files
- GHC/Cmm/Parser.y +2/−0
- GHC/CmmToAsm/AArch64/CodeGen.hs +73/−7
- GHC/CmmToAsm/AArch64/Instr.hs +6/−2
- GHC/CmmToAsm/AArch64/Ppr.hs +3/−1
- GHC/Core/FVs.hs +8/−1
- GHC/Core/Opt/Arity.hs +10/−21
- GHC/Core/Opt/CSE.hs +96/−32
- GHC/Core/Utils.hs +2/−1
- GHC/CoreToStg/Prep.hs +1/−33
- GHC/Data/IOEnv.hs +1/−1
- GHC/Driver/Errors.hs +6/−2
- GHC/Driver/Session.hs +9/−4
- GHC/Iface/Ext/Ast.hs +1/−1
- GHC/Iface/Tidy.hs +2/−2
- GHC/Parser/Errors.hs +3/−0
- GHC/Parser/Errors/Ppr.hs +3/−0
- GHC/Parser/PostProcess.hs +11/−4
- GHC/Platform.hs +5/−0
- GHC/Rename/Expr.hs +10/−0
- GHC/StgToByteCode.hs +11/−9
- GHC/StgToCmm/Prim.hs +1/−3
- GHC/Tc/Errors/Hole.hs +2/−1
- GHC/Tc/Gen/App.hs +22/−4
- GHC/Tc/Gen/Bind.hs +2/−2
- GHC/Tc/Gen/Expr.hs +3/−3
- GHC/Tc/Gen/Head.hs +11/−7
- GHC/Tc/Gen/Sig.hs +2/−2
- GHC/Tc/Module.hs +6/−1
- GHC/Tc/TyCl/Instance.hs +3/−2
- GHC/Tc/TyCl/PatSyn.hs +2/−1
- GHC/Tc/Types/Origin.hs +25/−2
- GHC/Tc/Utils/TcMType.hs +1/−1
- GHC/Tc/Utils/TcType.hs +36/−20
- GHC/Tc/Utils/Unify.hs +523/−139
- GHC/Tc/Validity.hs +18/−3
- GHC/Types/Demand.hs +4/−4
- GHC/Unit/Module/Graph.hs +2/−2
- ghc.cabal +4/−4
GHC/Cmm/Parser.y view
@@ -961,6 +961,8 @@ ( "eq", MO_Eq ), ( "ne", MO_Ne ), ( "mul", MO_Mul ),+ ( "mulmayoflo", MO_S_MulMayOflo ),+ ( "mulmayoflou", MO_U_MulMayOflo ), ( "neg", MO_S_Neg ), ( "quot", MO_S_Quot ), ( "rem", MO_S_Rem ),
GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -893,7 +893,7 @@ -- Signed multiply/divide MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL d x y)- MO_S_MulMayOflo w -> intOp True w (\d x y -> toOL [ MUL d x y, CSET d VS ])+ MO_S_MulMayOflo w -> do_mul_may_oflo w x y MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV d x y) -- No native rem instruction. So we'll compute the following@@ -978,6 +978,46 @@ ,0b0111_1111, 0b1111_1110 ,0b1111_1111] + -- N.B. MUL does not set the overflow flag.+ do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+ do_mul_may_oflo w@W64 x y = do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ lo <- getNewRegNat II64+ hi <- getNewRegNat II64+ return $ Any (intFormat w) (\dst ->+ code_x `appOL`+ code_y `snocOL`+ MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+ SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+ CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`+ CSET (OpReg w dst) NE)+ do_mul_may_oflo w x y = do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ let tmp_w = case w of+ W32 -> W64+ W16 -> W32+ W8 -> W32+ _ -> panic "do_mul_may_oflo: impossible"+ -- This will hold the product+ tmp <- getNewRegNat (intFormat tmp_w)+ let ext_mode = case w of+ W32 -> ESXTW+ W16 -> ESXTH+ W8 -> ESXTB+ _ -> panic "do_mul_may_oflo: impossible"+ mul = case w of+ W32 -> SMULL+ W16 -> MUL+ W8 -> MUL+ _ -> panic "do_mul_may_oflo: impossible"+ return $ Any (intFormat w) (\dst ->+ code_x `appOL`+ code_y `snocOL`+ mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+ CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`+ CSET (OpReg w dst) NE) -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.@@ -1579,14 +1619,34 @@ -- size we want to pack. Failure to get this right can result in pretty -- subtle bugs, e.g. #20137. - passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+ passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+ platform <- getPlatform let w = formatToWidth format- passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass gp argument: " <> ppr r) $ MOV (OpReg w gpReg) (OpReg w r)))+ mov+ -- Specifically, Darwin/AArch64's ABI requires that the caller+ -- sign-extend arguments which are smaller than 32-bits.+ | w < W32+ , platformCConvNeedsExtension platform+ , SignedHint <- hint+ = case w of+ W8 -> SXTB (OpReg W64 gpReg) (OpReg w r)+ W16 -> SXTH (OpReg W64 gpReg) (OpReg w r)+ _ -> panic "impossible"+ | otherwise+ = MOV (OpReg w gpReg) (OpReg w r)+ accumCode' = accumCode `appOL`+ code_r `snocOL`+ ann (text "Pass gp argument: " <> ppr r) mov+ passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode' -- Still have FP regs, and we want to pass an FP argument. passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do let w = formatToWidth format- passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass fp argument: " <> ppr r) $ MOV (OpReg w fpReg) (OpReg w r)))+ mov = MOV (OpReg w fpReg) (OpReg w r)+ accumCode' = accumCode `appOL`+ code_r `snocOL`+ ann (text "Pass fp argument: " <> ppr r) mov+ passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode' -- No mor regs left to pass. Must pass on stack. passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do@@ -1595,7 +1655,9 @@ space = if pack then bytes else 8 stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) | otherwise = stackSpace- stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+ str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+ stackCode = code_r `snocOL`+ ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.@@ -1605,7 +1667,9 @@ space = if pack then bytes else 8 stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) | otherwise = stackSpace- stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+ str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+ stackCode = code_r `snocOL`+ ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.@@ -1615,7 +1679,9 @@ space = if pack then bytes else 8 stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) | otherwise = stackSpace- stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+ str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+ stackCode = code_r `snocOL`+ ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
GHC/CmmToAsm/AArch64/Instr.hs view
@@ -80,6 +80,8 @@ MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) NEG dst src -> usage (regOp src, regOp dst)+ SMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+ SMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) UDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -209,6 +211,8 @@ MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)+ SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2) (patchOp o3)+ SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2) (patchOp o3) SDIV o1 o2 o3 -> SDIV (patchOp o1) (patchOp o2) (patchOp o3) SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) UDIV o1 o2 o3 -> UDIV (patchOp o1) (patchOp o2) (patchOp o3)@@ -562,8 +566,8 @@ -- | SMADDL ... -- | SMNEGL ... -- | SMSUBL ...- -- | SMULH ...- -- | SMULL ...+ | SMULH Operand Operand Operand+ | SMULL Operand Operand Operand | SUB Operand Operand Operand -- rd = rn - op2 -- | SUBS ... | UDIV Operand Operand Operand -- rd = rn ÷ rm
GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -328,7 +328,7 @@ OpReg w r -> pprReg w r OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i- OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <> comma <+> char '#' <> int i+ OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i OpImm im -> pprIm plat im OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i -- TODO: Address compuation always use registers as 64bit -- is this correct?@@ -408,6 +408,8 @@ MUL o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 | otherwise -> text "\tmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+ SMULH o1 o2 o3 -> text "\tsmulh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+ SMULL o1 o2 o3 -> text "\tsmull" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 NEG o1 o2 | isFloatOp o1 && isFloatOp o2 -> text "\tfneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2 | otherwise -> text "\tneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2
GHC/Core/FVs.hs view
@@ -625,7 +625,14 @@ dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var varTypeTyCoFVs :: Var -> FV-varTypeTyCoFVs var = tyCoFVsOfType (varType var)+-- Find the free variables of a binder.+-- In the case of ids, don't forget the multiplicity field!+varTypeTyCoFVs var+ = tyCoFVsOfType (varType var) `unionFV` mult_fvs+ where+ mult_fvs = case varMultMaybe var of+ Just mult -> tyCoFVsOfType mult+ Nothing -> emptyFV idFreeVars :: Id -> VarSet idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id
GHC/Core/Opt/Arity.hs view
@@ -776,12 +776,12 @@ andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2) | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2) = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]-andArityType (AT [] div1) at2+andArityType at1@(AT [] div1) at2 | isDeadEndDiv div1 = at2 -- Note [ABot branches: max arity wins]- | otherwise = takeWhileOneShot at2 -- See Note [Combining case branches]-andArityType at1 (AT [] div2)+ | otherwise = at1 -- See Note [Combining case branches]+andArityType at1 at2@(AT [] div2) | isDeadEndDiv div2 = at1 -- Note [ABot branches: max arity wins]- | otherwise = takeWhileOneShot at1 -- See Note [Combining case branches]+ | otherwise = at2 -- See Note [Combining case branches] {- Note [ABot branches: max arity wins] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -794,24 +794,13 @@ Note [Combining case branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- go = \x. let z = go e0- go2 = \x. case x of- True -> z- False -> \s(one-shot). e1- in go2 x-We *really* want to respect the one-shot annotation provided by the-user and eta-expand go and go2.-When combining the branches of the case we have- T `andAT` \1.T-and we want to get \1.T.-But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.-(We need a usage analysis to justify that.) -So we combine the best of the two branches, on the (slightly dodgy)-basis that if we know one branch is one-shot, then they all must be.-Surprisingly, this means that the one-shot arity type is effectively the top-element of the lattice.+Unless we can conclude that **all** branches are safe to eta-expand then we+must pessimisticaly conclude that we can't eta-expand. See #21694 for where this+went wrong.+We can do better in the long run, but for the 9.4/9.2 branches we choose to simply+ignore oneshot annotations for the time being.+ Note [Arity trimming] ~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/CSE.hs view
@@ -71,10 +71,28 @@ shadowing, but it doesn't any more (it proved too hard), so we clone as we go. We can simply add clones to the substitution already described. +A similar tricky situation is this, with x_123 and y_123 sharing the same unique: + let x_123 = e1 in+ let y_123 = e2 in+ let foo = e1++Naively applying e1 = x_123 during CSE we would get:++ let x_123 = e1 in+ let y_123 = e2 in+ let foo = x_123++But x_123 is shadowed by y_123 and things would go terribly wrong! One more reason+why we have to substitute binders as we go so we will properly get:++ let x1 = e1 in+ let x2 = e2 in+ let foo = x1+ Note [CSE for bindings] ~~~~~~~~~~~~~~~~~~~~~~~-Let-bindings have two cases, implemented by addBinding.+Let-bindings have two cases, implemented by extendCSEnvWithBinding. * SUBSTITUTE: applies when the RHS is a variable @@ -97,7 +115,7 @@ Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to the substitution so that we can CSE the binding for y2. - - Second, we use addBinding for case expression scrutinees too;+ - Second, we use extendCSEnvWithBinding for case expression scrutinees too; see Note [CSE for case expressions] * EXTEND THE REVERSE MAPPING: applies in all other cases@@ -138,7 +156,7 @@ case scrut_expr of x { ...alts... } This is very like a strict let-binding let !x = scrut_expr in ...-So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a+So we use (extendCSEnvWithBinding x scrut_expr) to process scrut_expr and x, and as a result all the stuff under Note [CSE for bindings] applies directly. For example:@@ -153,18 +171,18 @@ want to keep it as (wild1:as), but for CSE purpose that's a bad idea. - By using addBinding we add the binding (wild1 -> a) to the substitution,+ By using extendCSEnvWithBinding we add the binding (wild1 -> a) to the substitution, which does exactly the right thing. (Notice this is exactly backwards to what the simplifier does, which is to try to replaces uses of 'a' with uses of 'wild1'.) - This is the main reason that addBinding is called with a trivial rhs.+ This is the main reason that extendCSEnvWithBinding is called with a trivial rhs. * Non-trivial scrutinee case (f x) of y { pat -> ...let z = f x in ... } - By using addBinding we'll add (f x :-> y) to the cs_map, and+ By using extendCSEnvWithBinding we'll add (f x :-> y) to the cs_map, and thereby CSE the inner (f x) to y. Note [CSE for INLINE and NOINLINE]@@ -338,7 +356,27 @@ We can't use cs_map for this, because the key isn't an expression of the program; it's a kind of synthetic key for recursive bindings. +Note [Separate envs for let rhs and body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Substituting occurances of the binder in the rhs with the+ renamed binder is wrong for non-recursive bindings. Why?+Consider this core. + let {x_123 = e} in+ let {y_123 = \eta0 -> x_123} in ...++In the second line the y_123 on the lhs and x_123 on the rhs refer to different binders+even if they share the same unique.++If we apply the substitution `123 => x2_124}` to both the lhs and rhs we will transform+`let y_123 = \eta0 -> x_123` into `let x2_124 = \eta0 -> x2_124`.+However x2_124 on the rhs is not in scope and really shouldn't have been renamed at all.+Because really this should still be x_123! In fact this exact thing happened in #21685.++To fix this we pass two different cse envs to cse_bind. One we use the cse the rhs of the binding.+And one we update with the result of cseing the rhs which we then use going forward for the+body/rest of the module.+ ************************************************************************ * * \section{Common subexpression}@@ -353,8 +391,9 @@ cseBind toplevel env (NonRec b e) = (env2, NonRec b2 e2) where+ -- See Note [Separate envs for let rhs and body] (env1, b1) = addBinder env b- (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1+ (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1 cseBind toplevel env (Rec [(in_id, rhs)]) | noCSE in_id@@ -384,31 +423,33 @@ (env1, bndrs1) = addRecBinders env (map fst pairs) (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) - do_one env (pr, b1) = cse_bind toplevel env pr b1+ do_one env (pr, b1) = cse_bind toplevel env env pr b1 -- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer -- to @in_id@ (@out_id@, created from addBinder or addRecBinders), -- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd) -- binding to the 'CSEnv', so that we attempt to CSE any expressions -- which are equal to @out_rhs@.-cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))-cse_bind toplevel env (in_id, in_rhs) out_id+-- We use a different env for cse on the rhs and for extendCSEnvWithBinding+-- for reasons explain in See Note [Separate envs for let rhs and body]+cse_bind :: TopLevelFlag -> CSEnv -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))+cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id | isTopLevel toplevel, exprIsTickedString in_rhs -- See Note [Take care with literal strings]- = (env', (out_id', in_rhs))+ = (env_body', (out_id', in_rhs)) - | Just arity <- isJoinId_maybe in_id+ | Just arity <- isJoinId_maybe out_id -- See Note [Look inside join-point binders] = let (params, in_body) = collectNBinders arity in_rhs- (env', params') = addBinders env params+ (env', params') = addBinders env_rhs params out_body = tryForCSE env' in_body- in (env, (out_id, mkLams params' out_body))+ in (env_body , (out_id, mkLams params' out_body)) | otherwise- = (env', (out_id'', out_rhs))+ = (env_body', (out_id'', out_rhs)) where- (env', out_id') = addBinding env in_id out_id out_rhs cse_done- (cse_done, out_rhs) = try_for_cse env in_rhs+ (env_body', out_id') = extendCSEnvWithBinding env_body in_id out_id out_rhs cse_done+ (cse_done, out_rhs) = try_for_cse env_rhs in_rhs out_id'' | cse_done = zapStableUnfolding $ delayInlining toplevel out_id' | otherwise = out_id'@@ -428,7 +469,8 @@ | otherwise = bndr -addBinding :: CSEnv -- Includes InId->OutId cloning+extendCSEnvWithBinding+ :: CSEnv -- Includes InId->OutId cloning -> InVar -- Could be a let-bound type -> OutId -> OutExpr -- Processed binding -> Bool -- True <=> RHS was CSE'd and is a variable@@ -437,15 +479,16 @@ -- Extend the CSE env with a mapping [rhs -> out-id] -- unless we can instead just substitute [in-id -> rhs] ----- It's possible for the binder to be a type variable (see--- Note [Type-let] in GHC.Core), in which case we can just substitute.-addBinding env in_id out_id rhs' cse_done- | not (isId in_id) = (extendCSSubst env in_id rhs', out_id)- | noCSE in_id = (env, out_id)- | use_subst = (extendCSSubst env in_id rhs', out_id)- | cse_done = (env, out_id)+-- It's possible for the binder to be a type variable,+-- in which case we can just substitute.+-- See Note [CSE for bindings]+extendCSEnvWithBinding env in_id out_id rhs' cse_done+ | not (isId out_id) = (extendCSSubst env in_id rhs', out_id)+ | noCSE out_id = (env, out_id)+ | use_subst = (extendCSSubst env in_id rhs', out_id)+ | cse_done = (env, out_id) -- See Note [Dealing with ticks]- | otherwise = (extendCSEnv env rhs' id_expr', zapped_id)+ | otherwise = (extendCSEnv env rhs' id_expr', zapped_id) where id_expr' = varToCoreExpr out_id zapped_id = zapIdUsageInfo out_id@@ -518,8 +561,25 @@ an expression - when inserting into the cs_map (see extendCSEnv) - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse)- Quite why only the tickishFloatble ticks, I'm not quite sure.+ Quite why only the tickishFloatable ticks, I'm not quite sure. + AK: I think we only do this for floatable ticks since generally we don't mind them+ being less accurate as much. E.g. consider+ case e of+ C1 -> f (<tick1> e1)+ C2 -> f (<tick2> e1)+ If the ticks are (floatable) source notes nothing too bad happens if the debug info for+ both branches says the code comes from the same source location. Even if it will be inaccurate+ for one of the branches. We should probably still consider this worthwhile.+ However if the ticks are cost centres we really don't want the cost of both branches to be+ attributed to the same cost centre. Because a user might explicitly have inserted different+ cost centres in order to distinguish between evaluations resulting from the two different branches.+ e.g. something like this:+ case e of+ C1 -> f ({ SCC "evalAlt1"} e1)+ C1 -> f ({ SCC "evalAlt2"} e1)+ But it's still a bit suspicious.+ * If we get a hit in cs_map, we wrap the result in the ticks from the thing we are looking up (see try_for_cse) @@ -527,7 +587,7 @@ let x = tick t1 (tick t2 e) with let x = tick t1 (tick t2 y)-where 'y' is the variable that 'e' maps to. Now consider addBinding for+where 'y' is the variable that 'e' maps to. Now consider extendCSEnvWithBinding for the binding for 'x': * We can't use SUBSTITUTE because those ticks might not be trivial (we@@ -538,7 +598,7 @@ to the cs_map. Remember we strip off the ticks, so that would amount to adding y :-> x, very silly. -TL;DR: we do neither; hence the cse_done case in addBinding.+TL;DR: we do neither; hence the cse_done case in extendCSEnvWithBinding. Note [Delay inlining after CSE]@@ -664,8 +724,8 @@ -- in cse_alt may mean that a dead case binder -- becomes alive, and Lint rejects that (env1, bndr2) = addBinder env bndr1- (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 cse_done- -- addBinding: see Note [CSE for case expressions]+ (alt_env, bndr3) = extendCSEnvWithBinding env1 bndr bndr2 scrut1 cse_done+ -- extendCSEnvWithBinding: see Note [CSE for case expressions] con_target :: OutExpr con_target = lookupSubst alt_env bndr@@ -794,9 +854,12 @@ -- The substitution variables to -- /trivial/ OutExprs, not arbitrary expressions - , cs_map :: CoreMap OutExpr -- The reverse mapping+ , cs_map :: CoreMap OutExpr+ -- The "reverse" mapping. -- Maps a OutExpr to a /trivial/ OutExpr -- The key of cs_map is stripped of all Ticks+ -- It maps arbitrary expressions to trivial expressions+ -- representing the same value. E.g @C a b@ to @x1@. , cs_rec_map :: CoreMap OutExpr -- See Note [CSE for recursive bindings]@@ -810,6 +873,7 @@ lookupCSEnv (CS { cs_map = csmap }) expr = lookupCoreMap csmap expr +-- | @extendCSEnv env e triv_expr@ will replace any occurrence of @e@ with @triv_expr@ going forward. extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv extendCSEnv cse expr triv_expr = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
GHC/Core/Utils.hs view
@@ -84,6 +84,7 @@ import GHC.Types.Name import GHC.Types.Literal import GHC.Types.Tickish+import GHC.Types.Demand ( isDeadEndAppSig ) import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Types.Id@@ -1116,7 +1117,7 @@ | otherwise = go 0 e where- go n (Var v) = isDeadEndId v && n >= idArity v+ go n (Var v) = isDeadEndAppSig (idStrictness v) n go n (App e a) | isTypeArg a = go n e | otherwise = go (n+1) e go n (Tick _ e) = go n e
GHC/CoreToStg/Prep.hs view
@@ -32,10 +32,8 @@ import GHC.Unit import GHC.Builtin.Names-import GHC.Builtin.PrimOps import GHC.Builtin.Types-import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )-import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )+import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Core.Utils import GHC.Core.Opt.Arity@@ -1011,36 +1009,6 @@ -- 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)-- -- See Note [keepAlive# magic].- cpe_app env- (Var f)- args- n- | Just KeepAliveOp <- isPrimOpId_maybe f- , CpeApp (Type arg_rep)- : CpeApp (Type arg_ty)- : CpeApp (Type _result_rep)- : CpeApp (Type result_ty)- : CpeApp arg- : CpeApp s0- : CpeApp k- : rest <- args- = do { y <- newVar (cpSubstTy env result_ty)- ; 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- 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)]- ; (floats', expr') <- cpeBody env expr- ; return (floats `appendFloats` floats', expr')- }- | Just KeepAliveOp <- isPrimOpId_maybe f- = panic "invalid keepAlive# application" cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n | f `hasKey` runRWKey
GHC/Data/IOEnv.hs view
@@ -60,7 +60,7 @@ newtype IOEnv env a = IOEnv' (env -> IO a)- deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT env IO)+ deriving (MonadThrow, MonadCatch, MonadMask, MonadFix) via (ReaderT env IO) -- See Note [The one-shot state monad trick] in GHC.Utils.Monad instance Functor (IOEnv env) where
GHC/Driver/Errors.hs view
@@ -46,10 +46,14 @@ handleFlagWarnings logger dflags warns = do let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns + toWarnReason CmdLine.ReasonDeprecatedFlag = Reason Opt_WarnDeprecatedFlags+ toWarnReason CmdLine.ReasonUnrecognisedFlag = Reason Opt_WarnUnrecognisedWarningFlags+ toWarnReason CmdLine.NoReason = NoReason+ -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems.- bag = listToBag [ mkPlainWarnMsg loc (text warn)- | CmdLine.Warn _ (L loc warn) <- warns' ]+ bag = listToBag [ makeIntoWarning (toWarnReason reason) (mkPlainWarnMsg loc (text warn))+ | CmdLine.Warn reason (L loc warn) <- warns' ] printOrThrowWarnings logger dflags bag
GHC/Driver/Session.hs view
@@ -1372,12 +1372,14 @@ LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, LangExt.FieldSelectors,- LangExt.NondecreasingIndentation+ LangExt.NondecreasingIndentation, -- strictly speaking non-standard, but we always had this -- on implicitly before the option was added in 7.1, and -- turning it off breaks code, so we're keeping it on for -- backwards compatibility. Cabal uses -XHaskell98 by -- default unless you specify another language.+ LangExt.DeepSubsumption+ -- Non-standard but enabled for backwards compatability (see GHC proposal #511) ] languageExtensions (Just Haskell2010)@@ -1393,7 +1395,8 @@ LangExt.PatternGuards, LangExt.DoAndIfThenElse, LangExt.FieldSelectors,- LangExt.RelaxedPolyRec]+ LangExt.RelaxedPolyRec,+ LangExt.DeepSubsumption ] languageExtensions (Just GHC2021) = [LangExt.ImplicitPrelude,@@ -2449,7 +2452,7 @@ , make_ord_flag defGhcFlag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) , make_ord_flag defGhcFlag "ddump-llvm"- (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm)+ (NoArg $ setDumpFlag' Opt_D_dump_llvm) , make_ord_flag defGhcFlag "ddump-c-backend" (NoArg $ setDumpFlag' Opt_D_dump_c_backend) , make_ord_flag defGhcFlag "ddump-deriv"@@ -3611,6 +3614,7 @@ flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds,+ flagSpec "DeepSubsumption" LangExt.DeepSubsumption, flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf,@@ -4011,7 +4015,8 @@ Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, Opt_WarnNonCanonicalMonoidInstances,- Opt_WarnOperatorWhitespaceExtConflict+ Opt_WarnOperatorWhitespaceExtConflict,+ Opt_WarnUnicodeBidirectionalFormatCharacters ] -- | Things you get with -W
GHC/Iface/Ext/Ast.hs view
@@ -779,7 +779,7 @@ HsRecFld{} -> False HsOverLabel{} -> False HsIPVar{} -> False- XExpr (WrapExpr {}) -> False+ XExpr (ExpansionExpr {}) -> False _ -> True data HiePassEv p where
GHC/Iface/Tidy.hs view
@@ -60,7 +60,7 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info-import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig )+import GHC.Types.Demand ( isDeadEndAppSig, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName)@@ -1239,7 +1239,7 @@ _bottom_hidden id_sig = case mb_bot_str of Nothing -> False- Just (arity, _) -> not (appIsDeadEnd id_sig arity)+ Just (arity, _) -> not (isDeadEndAppSig id_sig arity) --------- Unfolding ------------ unf_info = unfoldingInfo idinfo
GHC/Parser/Errors.hs view
@@ -367,6 +367,9 @@ | PsErrLinearFunction -- ^ Linear function found but LinearTypes not enabled + | PsErrInvalidCApiImport+ -- ^ Invalid CApi import+ | PsErrMultiWayIf -- ^ Multi-way if-expression found but MultiWayIf not enabled
GHC/Parser/Errors/Ppr.hs view
@@ -584,6 +584,9 @@ PsErrLinearFunction -> text "Enable LinearTypes to allow linear functions" + PsErrInvalidCApiImport {}+ -> text "Wrapper stubs can't be used with CApiFFI."+ PsErrMultiWayIf -> text "Multi-way if-expressions need MultiWayIf turned on"
GHC/Parser/PostProcess.hs view
@@ -2500,9 +2500,13 @@ -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of- CCallConv -> mkCImport- CApiConv -> mkCImport- StdCallConv -> mkCImport+ CCallConv -> returnSpec =<< mkCImport+ CApiConv -> do+ imp <- mkCImport+ if isCWrapperImport imp+ then addFatalError $ PsError PsErrInvalidCApiImport [] loc+ else returnSpec imp+ StdCallConv -> returnSpec =<< mkCImport PrimCallConv -> mkOtherImport JavaScriptCallConv -> mkOtherImport where@@ -2514,7 +2518,10 @@ let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of Nothing -> addFatalError $ PsError PsErrMalformedEntityString [] loc- Just importSpec -> returnSpec importSpec+ Just importSpec -> return importSpec++ isCWrapperImport (CImport _ _ _ CWrapper _) = True+ isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in -- the entity string. If it is missing, we use the function name instead.
GHC/Platform.hs view
@@ -218,6 +218,11 @@ ArchPPC_64 _ -> True ArchS390X -> True ArchRISCV64 -> True+ ArchAArch64+ -- Apple's AArch64 ABI requires that the caller sign-extend+ -- small integer arguments. See+ -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms+ | OSDarwin <- platformOS platform -> True _ -> False
GHC/Rename/Expr.hs view
@@ -649,6 +649,16 @@ (e `op`) ==> op e with no auxiliary function at all. Simple! +* leftSection and rightSection switch on ImpredicativeTypes locally,+ during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider+ test DeepSubsumption08:+ type Setter st t a b = forall f. Identical f => blah+ (.~) :: Setter s t a b -> b -> s -> t+ clear :: Setter a a' b (Maybe b') -> a -> a'+ clear = (.~ Nothing)+ The expansion look like (rightSection (.~) Nothing). So we must+ instantiate `rightSection` first type argument to a polytype!+ Hence the special magic in App.wantQuickLook. Historical Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/StgToByteCode.hs view
@@ -70,7 +70,7 @@ import GHC.Types.Tickish import Data.List ( genericReplicate, genericLength, intersperse- , partition, scanl', sort, sortBy, zip4, zip6, nub )+ , partition, scanl', sortBy, zip4, zip6 ) import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char@@ -94,6 +94,7 @@ import qualified GHC.Types.CostCentre as CC import GHC.Stg.Syntax import GHC.Stg.FVs+import qualified Data.IntSet as IntSet -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module@@ -1162,16 +1163,16 @@ pointers = extra_pointers ++- sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))+ filter (< bitmap_size') (map (+extra_slots) rel_slots) where- binds = Map.toList p -- NB: unboxed tuple cases bind the scrut binder to the same offset -- as one of the alt binders, so we have to remove any duplicates here:- rel_slots = nub $ map fromIntegral $ concatMap spread binds- spread (id, offset) | isUnboxedTupleType (idType id) ||- isUnboxedSumType (idType id) = []- | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]- | otherwise = []+ -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'.+ rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p+ spread id offset | isUnboxedTupleType (idType id) ||+ isUnboxedSumType (idType id) = Nothing+ | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)+ | otherwise = Nothing where rel_offset = trunc16W $ bytesToWords platform (d - offset) bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers@@ -1566,6 +1567,7 @@ conv = case cconv of CCallConv -> FFICCall+ CApiConv -> FFICCall StdCallConv -> FFIStdCall _ -> panic "GHC.StgToByteCode: unexpected calling convention" @@ -2108,7 +2110,7 @@ StdCallConv -> True -- convention to ensure that a warning PrimCallConv -> False -- is triggered when a new one is added JavaScriptCallConv -> False- CApiConv -> False+ CApiConv -> True -- See bug #10462 unsupportedCConvException :: a
GHC/StgToCmm/Prim.hs view
@@ -1673,9 +1673,7 @@ TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal SetThreadAllocationCounter -> alwaysExternal-- -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.- KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"+ KeepAliveOp -> alwaysExternal where profile = targetProfile dflags
GHC/Tc/Errors/Hole.hs view
@@ -958,7 +958,7 @@ -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $- tcSubTypeSigma ExprSigCtxt ty hole_ty+ tcSubTypeSigma orig ExprSigCtxt ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted ; if isEmptyWC wanted && isEmptyBag th_relevant_cts@@ -985,6 +985,7 @@ ; traceTc "}" empty ; return (isSolvedWC rem, wrap) } } where+ orig = ExprHoleOrigin (hole_occ <$> th_hole) setWCAndBinds :: EvBindsVar -- Fresh ev binds var. -> Implication -- The implication to put WC in. -> WantedConstraints -- The WC constraints to put implic.
GHC/Tc/Gen/App.hs view
@@ -289,6 +289,7 @@ the renamer (Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr), and we want them to be instantiated impredicatively so that (f `op`), say, will work OK even if `f` is higher rank.+ See Note [Left and right sections] in GHC.Rename.Expr. Note [Unify with expected type before typechecking arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -349,9 +350,27 @@ = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $ thing_inside - ; res_co <- perhaps_add_res_ty_ctxt $- unifyExpectedType rn_expr app_res_rho exp_res_ty+ -- Match up app_res_rho: the result type of rn_expr+ -- with exp_res_ty: the expected result type+ ; do_ds <- xoptM LangExt.DeepSubsumption+ ; res_wrap <- perhaps_add_res_ty_ctxt $+ if not do_ds+ then -- No deep subsumption+ -- app_res_rho and exp_res_ty are both rho-types,+ -- so with simple subsumption we can just unify them+ -- No need to zonk; the unifier does that+ do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty+ ; return (mkWpCastN co) } + else -- Deep subsumption+ -- Even though both app_res_rho and exp_res_ty are rho-types,+ -- they may have nested polymorphism, so if deep subsumption+ -- is on we must call tcSubType.+ -- Zonk app_res_rho first, becuase QL may have instantiated some+ -- delta variables to polytypes, and tcSubType doesn't expect that+ do { app_res_rho <- zonkQuickLook do_ql app_res_rho+ ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }+ ; whenDOptM Opt_D_dump_tc_trace $ do { inst_args <- mapM zonkArg inst_args -- Only when tracing ; traceTc "tcApp" (vcat [ text "rn_fun" <+> ppr rn_fun@@ -372,11 +391,10 @@ else return (rebuildHsApps tc_fun fun_ctxt tc_args) -- Wrap the result- ; return (mkHsWrapCo res_co tc_expr) }+ ; return (mkHsWrap res_wrap tc_expr) } -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool--- GHC switches on impredicativity all the time for ($) wantQuickLook (HsVar _ (L _ f)) | getUnique f `elem` quickLookKeys = return True wantQuickLook _ = xoptM LangExt.ImpredicativeTypes
GHC/Tc/Gen/Bind.hs view
@@ -624,7 +624,7 @@ tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah- -- NB: tcSkolemise makes fresh type variables+ -- NB: tcSkolemiseScoped makes fresh type variables -- See Note [Instantiate sig with fresh variables] let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in@@ -802,7 +802,7 @@ -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $- tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty+ tcSubTypeSigma GhcBug20076 sig_ctxt sel_poly_ty poly_ty ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures ; when warn_missing_sigs $
GHC/Tc/Gen/Expr.hs view
@@ -172,7 +172,7 @@ tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcPolyExpr expr res_ty = do { traceTc "tcPolyExpr" (ppr res_ty)- ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+ ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> tcExpr expr res_ty ; return $ mkHsWrap wrap expr' } @@ -1010,8 +1010,8 @@ -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper))- <- tcSkolemise GenSigCtxt sigma_ty $ \ rho_ty ->- go rho_ty syn_ty+ <- tcTopSkolemise GenSigCtxt sigma_ty+ (\ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny
GHC/Tc/Gen/Head.hs view
@@ -763,7 +763,7 @@ then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int- else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma+ else tcSubTypeSigma ExprSigOrigin ExprSigCtxt inferred_sigma my_sigma ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap@@ -1191,9 +1191,9 @@ ; let -- See Note [Splitting nested sigma types in mismatched -- function types] (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'- -- No need to call tcSplitNestedSigmaTys here, since env_ty is- -- an ExpRhoTy, i.e., it's already instantiated.- (_, _, env_tau) = tcSplitSigmaTy env'+ (_, _, env_tau) = tcSplitNestedSigmaTys env'+ -- env_ty is an ExpRhoTy, but with simple subsumption it+ -- is not deeply skolemised, so still use tcSplitNestedSigmaTys (args_fun, res_fun) = tcSplitFunTys fun_tau (args_env, res_env) = tcSplitFunTys env_tau n_fun = length args_fun@@ -1240,7 +1240,7 @@ This is incorrect in the face of nested foralls, however! This caused Ticket #13311, for instance: - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b+ f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b If one uses `f` like so: @@ -1251,7 +1251,7 @@ Tyvars: [a] Context: (Monoid a) Argument types: []- Return type: forall b. Monoid b => Maybe a -> Maybe b+ Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b That is, it will conclude that there are *no* argument types, and since `f` was given no arguments, it won't print a helpful error message. On the other@@ -1259,11 +1259,15 @@ Tyvars: [a, b] Context: (Monoid a, Monoid b)- Argument types: [Maybe a]+ Argument types: [Int, Maybe a] Return type: Maybe b So now GHC recognizes that `f` has one more argument type than it was actually provided.++Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless+of simple/deep subsumption. Here we are concerned only whether there is a+mis-match in the number of value arguments. -}
GHC/Tc/Gen/Sig.hs view
@@ -38,7 +38,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Validity ( checkValidType )-import GHC.Tc.Utils.Unify( tcSkolemise, unifyType )+import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )@@ -791,7 +791,7 @@ -- See Note [Handling SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap)- <- tcSkolemise ctxt spec_ty $ \ spec_tau ->+ <- tcTopSkolemise ctxt spec_ty $ \ spec_tau -> do { (inst_wrap, tau) <- topInstantiate orig poly_ty ; _ <- unifyType Nothing spec_tau tau -- Deliberately ignore the evidence
GHC/Tc/Module.hs view
@@ -1785,9 +1785,14 @@ ctxt = FunSigCtxt main_name False ; main_id <- tcLookupId main_name ; (io_ty,_) <- getIOType+ ; let main_ty = idType main_id+ eq_orig = TypeEqOrigin { uo_actual = main_ty+ , uo_expected = io_ty+ , uo_thing = Nothing+ , uo_visible = True } ; (_, lie) <- captureTopConstraints $ setMainCtxt main_name io_ty $- tcSubTypeSigma ctxt (idType main_id) io_ty+ tcSubTypeSigma eq_orig ctxt main_ty io_ty ; return lie } } } } checkMain :: Bool -- False => no 'module M(..) where' header at all
GHC/Tc/TyCl/Instance.hs view
@@ -966,7 +966,7 @@ can't skolemise in kinds because we don't have type-level lambda. But here, we're at the top-level of an instance declaration, so we actually have a place to put the regeneralised variables.-Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcSkolemise+Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise Examples in indexed-types/should_compile/T12369 Note [Implementing eta reduction for data families]@@ -1901,8 +1901,9 @@ -- checking instance-sig <= class-meth-sig -- The instance-sig is the focus here; the class-meth-sig -- is fixed (#18036)+ ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $- tcSubTypeSigma ctxt sig_ty local_meth_ty+ tcSubTypeSigma orig ctxt sig_ty local_meth_ty ; return (sig_ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name)
GHC/Tc/TyCl/PatSyn.hs view
@@ -500,7 +500,8 @@ -- Else the error message location is wherever tcCheckPat finished, -- namely the right-hand corner of the pattern do { arg_id <- tcLookupId arg_name- ; wrap <- tcSubTypeSigma GenSigCtxt+ ; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id))+ GenSigCtxt (idType arg_id) (substTy subst arg_ty) -- Why do we need tcSubType here?
GHC/Tc/Types/Origin.hs view
@@ -461,7 +461,7 @@ -- We only need a CtOrigin on the first, because the location -- is pinned on the entire error message - | ExprHoleOrigin OccName -- from an expression hole+ | ExprHoleOrigin (Maybe OccName) -- from an expression hole | TypeHoleOrigin OccName -- from a type hole (partial type signature) | PatCheckOrigin -- normalisation of a type during pattern-match checking | ListOrigin -- An overloaded list@@ -481,6 +481,13 @@ CtOrigin -- origin of the original constraint -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical + | InstanceSigOrigin -- from the sub-type check of an InstanceSig+ Name -- the method name+ Type -- the instance-sig type+ Type -- the instantiated type of the method+ | AmbiguityCheckOrigin UserTypeCtxt+ | GhcBug20076+ -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given.@@ -660,6 +667,18 @@ pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig +pprCtOrigin (InstanceSigOrigin method_name sig_type orig_method_type)+ = vcat [ ctoHerald <+> text "the check that an instance signature is more general"+ , text "than the type of the method (instantiated for this instance)"+ , hang (text "instance signature:")+ 2 (ppr method_name <+> dcolon <+> ppr sig_type)+ , hang (text "instantiated method type:")+ 2 (ppr orig_method_type) ]++pprCtOrigin (AmbiguityCheckOrigin ctxt)+ = ctoHerald <+> text "a type ambiguity check for" $$+ pprUserTypeCtxt ctxt+ pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin @@ -693,7 +712,8 @@ pprCtO MCompOrigin = text "a statement in a monad comprehension" pprCtO ProcOrigin = text "a proc expression" pprCtO AnnOrigin = text "an annotation"-pprCtO (ExprHoleOrigin occ) = text "a use of" <+> quotes (ppr occ)+pprCtO (ExprHoleOrigin Nothing) = text "an expression hole"+pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) pprCtO PatCheckOrigin = text "a pattern-match completeness check" pprCtO ListOrigin = text "an overloaded list"@@ -701,4 +721,7 @@ pprCtO NonLinearPatternOrigin = text "a non-linear pattern" pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO BracketOrigin = text "a quotation bracket"+pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance"+pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check"+pprCtO GhcBug20076 = text "GHC Bug #20076" pprCtO _ = panic "pprCtOrigin"
GHC/Tc/Utils/TcMType.hs view
@@ -283,7 +283,7 @@ ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) ; let her = HER ref ty u - ; loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel)+ ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) ; let hole = Hole { hole_sort = ExprHole her , hole_occ = occ
GHC/Tc/Utils/TcType.hs view
@@ -1316,34 +1316,50 @@ (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s--- as possible. For example, given this type synonym:------ @--- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t--- @------ if you called @tcSplitSigmaTy@ on this type:------ @--- forall s t a b. Each s t a b => Traversal s t a b--- @------ then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But--- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return--- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@.+-- | Split a sigma type into its parts, going underneath as many arrows+-- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)--- NB: This is basically a pure version of topInstantiate (from Inst) that--- doesn't compute an HsWrapper.+-- See Note [tcSplitNestedSigmaTys]+-- NB: This is basically a pure version of deeplyInstantiate (from Unify) that+-- doesn't compute an HsWrapper. tcSplitNestedSigmaTys ty -- If there's a forall, split it apart and try splitting the rho type -- underneath it.- | (tvs1, theta1, rho1) <- tcSplitSigmaTy ty+ | (arg_tys, body_ty) <- tcSplitFunTys ty+ , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty , not (null tvs1 && null theta1) = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1- in (tvs1 ++ tvs2, theta1 ++ theta2, rho2)+ in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2)+ -- If there's no forall, we're done. | otherwise = ([], [], ty)++{- Note [tcSplitNestedSigmaTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcSplitNestedSigmaTys splits out all the /nested/ foralls and constraints,+including under function arrows. E.g. given this type synonym:+ type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++then+ tcSplitNestedSigmaTys (forall s t a b. C s t a b => Int -> Traversal s t a b)++will return+ ( [s,t,a,b,f]+ , [C s t a b, Applicative f]+ , Int -> (a -> f b) -> s -> f t)@.++This function is used in these places:+* Improving error messages in GHC.Tc.Gen.Head.addFunResCtxt+* Validity checking for default methods: GHC.Tc.TyCl.checkValidClass+* A couple of calls in the GHCi debugger: GHC.Runtime.Heap.Inspect++In other words, just in validity checking and error messages; hence+no wrappers or evidence generation.++Notice that tcSplitNestedSigmaTys even looks under function arrows;+doing so is the Right Thing even with simple subsumption, not just+with deep subsumption.+-} ----------------------- tcTyConAppTyCon :: Type -> TyCon
GHC/Tc/Utils/Unify.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -15,9 +16,9 @@ module GHC.Tc.Utils.Unify ( -- Full-blown subsumption tcWrapResult, tcWrapResultO, tcWrapResultMono,- tcSkolemise, tcSkolemiseScoped, tcSkolemiseET,- tcSubType, tcSubTypeSigma, tcSubTypePat,- tcSubMult,+ tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType,+ tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,+ tcSubTypeAmbiguity, tcSubMult, checkConstraints, checkTvConstraints, buildImplicationFor, buildTvImplication, emitResidualTvConstraint, @@ -54,13 +55,16 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity+import qualified GHC.LanguageExtensions as LangExt+ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import GHC.Types.Name( isSystemName )+ import GHC.Tc.Utils.Instantiate import GHC.Core.TyCon import GHC.Builtin.Types+import GHC.Types.Name( Name, isSystemName ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env@@ -68,13 +72,13 @@ import GHC.Driver.Session import GHC.Types.Basic import GHC.Data.Bag+import GHC.Data.FastString( fsLit ) import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Exts ( inline ) import Control.Monad-import Control.Arrow ( second ) import qualified Data.Semigroup as S ( (<>) ) {- *********************************************************************@@ -306,7 +310,7 @@ go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty , not (null tvs && null theta)- = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->+ = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> go acc_arg_tys n ty' ; return (wrap_gen <.> wrap_res, result) } @@ -513,9 +517,36 @@ co_fn :: actual_ty ~ expected_ty which takes an HsExpr of type actual_ty into one of type expected_ty.++Note [Ambiguity check and deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f :: (forall b. Eq b => a -> a) -> Int++Does `f` have an ambiguous type? The ambiguity check usually checks+that this definition of f' would typecheck, where f' has the exact same+type as f:+ f' :: (forall b. Eq b => a -> a) -> Intp+ f' = f++This will be /rejected/ with DeepSubsumption but /accepted/ with+ShallowSubsumption. On the other hand, this eta-expanded version f''+would be rejected both ways:+ f'' :: (forall b. Eq b => a -> a) -> Intp+ f'' x = f x++This is squishy in the same way as other examples in GHC.Tc.Validity+Note [The squishiness of the ambiguity check]++The situation in June 2022. Since we have SimpleSubsumption at the moment,+we don't want introduce new breakage if you add -XDeepSubsumption, by+rejecting types as ambiguous that weren't ambiguous before. So, as a+holding decision, we /always/ use SimpleSubsumption for the ambiguity check+(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. -} + ----------------- -- tcWrapResult needs both un-type-checked (for origins and error messages) -- and type-checked (for wrapping) expressions@@ -580,12 +611,33 @@ 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+---------------+tcSubTypeDS :: HsExpr GhcRn+ -> TcRhoType -- Actual -- a rho-type not a sigma-type+ -> ExpRhoType -- Expected -> TcM HsWrapper+-- Similar signature to unifyExpectedType; does deep subsumption+-- Only one call site, in GHC.Tc.Gen.App.tcApp+tcSubTypeDS rn_expr act_rho res_ty+ = case res_ty of+ Check exp_rho -> do { dflags <- getDynFlags+ ; tc_sub_type_deep dflags (unifyType m_thing) orig+ GenSigCtxt act_rho exp_rho+ }++ Infer inf_res -> do { co <- fillInferResult act_rho inf_res+ ; return (mkWpCastN co) }+ where+ orig = exprCtOrigin rn_expr+ m_thing = Just (ppr rn_expr)++---------------+tcSubTypeNC :: CtOrigin -- ^ Used when instantiating+ -> UserTypeCtxt -- ^ Used when skolemising+ -> Maybe SDoc -- ^ The expression that has type 'actual' (if known)+ -> TcSigmaType -- ^ Actual type+ -> ExpRhoType -- ^ Expected type+ -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of Check ty_expected -> do { dflags <- getDynFlags@@ -597,6 +649,51 @@ ; co <- fillInferResult rho inf_res ; return (mkWpCastN co <.> wrap) } +---------------+tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we+ -- doing this subtype check?+ -> UserTypeCtxt -- where did the expected type arise?+ -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- External entry point, but no ExpTypes on either side+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubTypeSigma orig ctxt ty_actual ty_expected+ = do { dflags <- getDynFlags+ ; tc_sub_type dflags (unifyType Nothing) orig ctxt ty_actual ty_expected+ }++---------------+tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise+ -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- See Note [Ambiguity check and deep subsumption]+tcSubTypeAmbiguity ctxt ty_actual ty_expected+ = do { dflags <- getDynFlags+ ; tc_sub_type_shallow dflags (unifyType Nothing)+ (AmbiguityCheckOrigin ctxt)+ ctxt ty_actual ty_expected+ }++---------------+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+ where+ mk_msg tidy_env+ = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual+ ; ty_expected <- readExpType ty_expected+ -- A worry: might not be filled if we're debugging. Ugh.+ ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+ ; let msg = vcat [ hang (text "When checking that:")+ 4 (ppr ty_actual)+ , nest 2 (hang (text "is more polymorphic than:")+ 2 (ppr ty_expected)) ]+ ; return (tidy_env, msg) }++ {- Note [Instantiation of InferResult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We now always instantiate before filling in InferResult, so that@@ -620,7 +717,7 @@ f :: (?x :: Int) => a -> a g y = let ?x = 3::Int in f Here want to instantiate f's type so that the ?x::Int constraint- gets discharged by the enclosing implicit-parameter binding.+ gets discharged by the enclosing implicit-parameter binding. 3. Suppose one defines plus = (+). If we instantiate lazily, we will infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism@@ -635,33 +732,34 @@ -} ----------------tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper--- External entry point, but no ExpTypes on either side--- Checks that actual <= expected--- Returns HsWrapper :: actual ~ expected-tcSubTypeSigma ctxt ty_actual ty_expected- = do { dflags <- getDynFlags- ; tc_sub_type dflags (unifyType Nothing) eq_orig ctxt ty_actual ty_expected }- where- eq_orig = TypeEqOrigin { uo_actual = ty_actual- , uo_expected = ty_expected- , uo_thing = Nothing- , uo_visible = True }------------------tc_sub_type :: DynFlags- -> (TcType -> TcType -> TcM TcCoercionN) -- How to unify- -> CtOrigin -- Used when instantiating- -> UserTypeCtxt -- Used when skolemising- -> TcSigmaType -- Actual; a sigma-type- -> TcSigmaType -- Expected; also a sigma-type- -> TcM HsWrapper+tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow+ :: DynFlags+ -> (TcType -> TcType -> TcM TcCoercionN) -- How to unify+ -> CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> TcSigmaType -- Actual; a sigma-type+ -> TcSigmaType -- Expected; also a sigma-type+ -> TcM HsWrapper -- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2+--+-- The "how to unify argument" is always a call to `uType TypeLevel orig`,+-- but with different ways of constructing the CtOrigin `orig` from+-- the argument types and context.++---------------------- tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected- | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily]- , not (possibly_poly ty_actual)+ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; if deep_subsumption+ then tc_sub_type_deep dflags unify inst_orig ctxt ty_actual ty_expected+ else tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected+ }++----------------------+tc_sub_type_shallow dflags unify inst_orig ctxt ty_actual ty_expected+ | definitely_poly dflags ty_expected -- See Note [Don't skolemise unnecessarily]+ , definitely_mono_shallow ty_actual = do { traceTc "tc_sub_type (drop to equality)" $ vcat [ text "ty_actual =" <+> ppr ty_actual , text "ty_expected =" <+> ppr ty_expected ]@@ -674,52 +772,67 @@ , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap)- <- tcSkolemise ctxt ty_expected $ \ sk_rho ->+ <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual ; cow <- unify rho_a sk_rho ; return (mkWpCastN cow <.> wrap) } ; return (sk_wrap <.> inner_wrap) }- where- possibly_poly ty = not (isRhoTy ty) - definitely_poly ty- | (tvs, theta, tau) <- tcSplitSigmaTy ty- , (tv:_) <- tvs- , null theta- , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs- = True- | otherwise- = False+----------------------+tc_sub_type_deep dflags unify inst_orig ctxt ty_actual ty_expected+ | definitely_poly dflags ty_expected -- See Note [Don't skolemise unnecessarily]+ , definitely_mono_deep ty_actual+ = do { traceTc "tc_sub_type_deep (drop to equality)" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ]+ ; mkWpCastN <$>+ unify ty_actual ty_expected } --------------------------addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a-addSubTypeCtxt ty_actual ty_expected thing_inside- | isRhoTy ty_actual -- If there is no polymorphism involved, the- , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions)- = thing_inside -- gives enough context by itself- | otherwise- = addErrCtxtM mk_msg thing_inside- where- mk_msg tidy_env- = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual- -- might not be filled if we're debugging. ugh.- ; mb_ty_expected <- readExpType_maybe ty_expected- ; (tidy_env, ty_expected) <- case mb_ty_expected of- Just ty -> second mkCheckExpType <$>- zonkTidyTcType tidy_env ty- Nothing -> return (tidy_env, ty_expected)- ; ty_expected <- readExpType ty_expected- ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected- ; let msg = vcat [ hang (text "When checking that:")- 4 (ppr ty_actual)- , nest 2 (hang (text "is more polymorphic than:")- 2 (ppr ty_expected)) ]- ; return (tidy_env, msg) }+ | otherwise -- This is the general case+ = do { traceTc "tc_sub_type_deep (general case)" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ] + ; (sk_wrap, inner_wrap)+ <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho ->+ -- See Note [Deep subsumption]+ tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho++ ; return (sk_wrap <.> inner_wrap) }++definitely_mono_shallow :: TcType -> Bool+definitely_mono_shallow ty = isRhoTy ty+ -- isRhoTy: no top level forall or (=>)++definitely_mono_deep :: TcType -> Bool+definitely_mono_deep ty+ | not (definitely_mono_shallow ty) = False+ -- isRhoTy: False means top level forall or (=>)+ | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res+ -- Top level (->)+ | otherwise = True++definitely_poly :: DynFlags -> TcType -> Bool+-- A very conservative test:+-- see Note [Don't skolemise unnecessarily]+definitely_poly dflags ty+ | (tvs, theta, tau) <- tcSplitSigmaTy ty+ , (tv:_) <- tvs -- At least one tyvar+ , null theta -- No constraints; see (DP1)+ , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs+ -- The tyvar actually occurs (DP2),+ -- and occurs in an injective position (DP3).+ -- Fortunately checkTyVarEq, used for the occur check,+ -- is just what we need.+ = True+ | otherwise+ = False+ {- Note [Don't skolemise unnecessarily] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are trying to solve+ ty_actual <= ty_expected (Char->Char) <= (forall a. a->a) We could skolemise the 'forall a', and then complain that (Char ~ a) is insoluble; but that's a pretty obscure@@ -727,55 +840,26 @@ (Char->Char) ~ (forall a. a->a) fails. -So roughly:- * if the ty_expected has an outermost forall- (i.e. skolemisation is the next thing we'd do)- * and the ty_actual has no top-level polymorphism (but looking deeply)-then we can revert to simple equality. But we need to be careful.-These examples are all fine:-- * (Char->Char) <= (forall a. Char -> Char)- ty_expected isn't really polymorphic-- * (Char->Char) <= (forall a. (a~Char) => a -> a)- ty_expected isn't really polymorphic-- * (Char->Char) <= (forall a. F [a] Char -> Char)- where type instance F [x] t = t- ty_expected isn't really polymorphic- If we prematurely go to equality we'll reject a program we should-accept (e.g. #13752). So the test (which is only to improve-error message) is very conservative:- * ty_actual is /definitely/ monomorphic- * ty_expected is /definitely/ polymorphic+accept (e.g. #13752). So the test (which is only to improve error+message) is very conservative: -Note [Settting the argument context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we are doing the ambiguity check for the (bogus)- f :: (forall a b. C b => a -> a) -> Int+ * ty_actual is /definitely/ monomorphic: see `definitely_mono`+ This definitely_mono test comes in "shallow" and "deep" variants -We'll call- tcSubType ((forall a b. C b => a->a) -> Int )- ((forall a b. C b => a->a) -> Int )+ * ty_expected is /definitely/ polymorphic: see `definitely_poly`+ This definitely_poly test is more subtle than you might think.+ Here are three cases where expected_ty looks polymorphic, but+ isn't, and where it would be /wrong/ to switch to equality: -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing-on the argument type of the (->) -- and at that point we want to switch-to a UserTypeCtxt of GenSigCtxt. Why?+ (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) -* Error messages. If we stick with FunSigCtxt we get errors like- * Could not deduce: C b- from the context: C b0- bound by the type signature for:- f :: forall a b. C b => a->a- But of course f does not have that type signature!- Example tests: T10508, T7220a, Simple14+ (DP2) (Char->Char) <= (forall a. Char -> Char) -* Implications. We may decide to build an implication for the whole- ambiguity check, but we don't need one for each level within it,- and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt.- See Note [When to build an implication]+ (DP3) (Char->Char) <= (forall a. F [a] Char -> Char)+ where type instance F [x] t = t + Note [Wrapper returned from tcSubMult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is no notion of multiplicity coercion in Core, therefore the wrapper@@ -824,13 +908,304 @@ {- ********************************************************************* * *+ Deep subsumption+* *+********************************************************************* -}++{- Note [Deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The DeepSubsumption extension, documented here++ https://github.com/ghc-proposals/ghc-proposals/pull/511.++makes a best-efforts attempt implement deep subsumption as it was+prior to the the Simplify Subsumption proposal:++ https://github.com/ghc-proposals/ghc-proposals/pull/287++The effects are in these main places:++1. In the subsumption check, tcSubType, we must do deep skolemisation:+ see the call to tcDeeplySkolemise in tc_sub_type_deep++2. In tcPolyExpr we must do deep skolemisation:+ see the call to tcDeeplySkolemise in tcSkolemiseExpType++3. for expression type signatures (e :: ty), and functions with type+ signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;+ see the call to tcDeeplySkolemise in tcSkolemiseScoped.++4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result+ type. Without deep subsumption, unifyExpectedType would be sufficent.++In all these cases note that the deep skolemisation must be done /first/.+Consider (1)+ (forall a. Int -> a -> a) <= Int -> (forall b. b -> b)+We must skolemise the `forall b` before instantiating the `forall a`.+See also Note [Deep skolemisation].++Note that we /always/ use shallow subsumption in the ambiguity check.+See Note [Ambiguity check and deep subsumption].++Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~+deeplySkolemise decomposes and skolemises a type, returning a type+with all its arrows visible (ie not buried under foralls)++Examples:++ deeplySkolemise (Int -> forall a. Ord a => blah)+ = ( wp, [a], [d:Ord a], Int -> blah )+ where wp = \x:Int. /\a. \(d:Ord a). <hole> x++ deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)+ = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )+ where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x++In general,+ if deeplySkolemise ty = (wrap, tvs, evs, rho)+ and e :: rho+ then wrap e :: ty+ and 'wrap' binds tvs, evs++ToDo: this eta-abstraction plays fast and loose with termination,+ because it can introduce extra lambdas. Maybe add a `seq` to+ fix this++Note [Setting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we are doing the ambiguity check for the (bogus)+ f :: (forall a b. C b => a -> a) -> Int++We'll call+ tcSubType ((forall a b. C b => a->a) -> Int )+ ((forall a b. C b => a->a) -> Int )++with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing+on the argument type of the (->) -- and at that point we want to switch+to a UserTypeCtxt of GenSigCtxt. Why?++* Error messages. If we stick with FunSigCtxt we get errors like+ * Could not deduce: C b+ from the context: C b0+ bound by the type signature for:+ f :: forall a b. C b => a->a+ But of course f does not have that type signature!+ Example tests: T10508, T7220a, Simple14++* Implications. We may decide to build an implication for the whole+ ambiguity check, but we don't need one for each level within it,+ and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.+ See Note [When to build an implication]++Note [Multiplicity in deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ t1 ->{mt} t2 <= s1 ->{ms} s2++At the moment we /unify/ ms~mt, via tcEqMult.++Arguably we should use `tcSubMult`. But then if mt=m0 (a unification+variable) and ms=Many, `tcSubMult` is a no-op (since anything is a+sub-multiplicty of Many). But then `m0` may never get unified with+anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds+Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base+we get this++ "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys+ = \xs -> xs ++ ys++where we eta-expanded that (:). But now foldr expects an argument+with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint+complains.++The easiest solution was to use tcEqMult in tc_sub_type_ds, and+insist on equality. This is only in the DeepSubsumption code anyway.+-}++tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify+ -> CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> TcSigmaType -- Actual; a sigma-type+ -> TcRhoType -- Expected; deeply skolemised+ -> TcM HsWrapper++-- If wrap = tc_sub_type_ds t1 t2+-- => wrap :: t1 ~> t2+-- Here is where the work actually happens!+-- Precondition: ty_expected is deeply skolemised++tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected+ = do { traceTc "tc_sub_type_ds" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ]+ ; go ty_actual ty_expected }+ where+ -- NB: 'go' is not recursive, except for doing tcView+ go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e+ | Just ty_e' <- tcView ty_e = go ty_a ty_e'++ go (TyVarTy tv_a) ty_e+ = do { lookup_res <- isFilledMetaTyVar_maybe tv_a+ ; case lookup_res of+ Just ty_a' ->+ do { traceTc "tc_sub_type_ds following filled meta-tyvar:"+ (ppr tv_a <+> text "-->" <+> ppr ty_a')+ ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e }+ Nothing -> just_unify ty_actual ty_expected }++ go ty_a@(FunTy { ft_af = VisArg, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res })+ ty_e@(FunTy { ft_af = VisArg, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })+ | isTauTy ty_a, isTauTy ty_e -- Short cut common case to avoid+ = just_unify ty_actual ty_expected -- unnecessary eta expansion++ | otherwise+ = -- This is where we do the co/contra thing, and generate a WpFun, which in turn+ -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption+ do { dflags <- getDynFlags+ ; arg_wrap <- tc_sub_type_deep dflags unify given_orig GenSigCtxt exp_arg act_arg+ -- GenSigCtxt: See Note [Setting the argument context]+ ; res_wrap <- tc_sub_type_ds unify inst_orig ctxt act_res exp_res+ ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult+ -- See Note [Multiplicity in deep subsumption]+ ; let doc = text "When checking that" <+> quotes (ppr ty_actual)+ <+> text "is more polymorphic than" <+> quotes (ppr ty_expected)+ ; return (mult_wrap <.>+ mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res doc)}+ -- arg_wrap :: exp_arg ~> act_arg+ -- res_wrap :: act-res ~> exp_res+ where+ given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])++ go ty_a ty_e+ | let (tvs, theta, _) = tcSplitSigmaTy ty_a+ , not (null tvs && null theta)+ = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a+ ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e+ ; return (body_wrap <.> in_wrap) }++ | otherwise -- Revert to unification+ = do { -- It's still possible that ty_actual has nested foralls. Instantiate+ -- these, as there's no way unification will succeed with them in.+ -- See typecheck/should_compile/T11305 for an example of when this+ -- is important. The problem is that we're checking something like+ -- a -> forall b. b -> b <= alpha beta gamma+ -- where we end up with alpha := (->)+ (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual+ ; unify_wrap <- just_unify rho_a ty_expected+ ; return (unify_wrap <.> inst_wrap) }++ just_unify ty_a ty_e = do { cow <- unify ty_a ty_e+ ; return (mkWpCastN cow) }++tcDeeplySkolemise+ :: UserTypeCtxt -> TcSigmaType+ -> (TcType -> TcM result)+ -> TcM (HsWrapper, result)+ -- ^ The wrapper has type: spec_ty ~> expected_ty+-- Just like tcTopSkolemise, but calls+-- deeplySkolemise instead of topSkolemise+-- See Note [Deep skolemisation]+tcDeeplySkolemise ctxt expected_ty thing_inside+ | isTauTy expected_ty -- Short cut for common case+ = do { res <- thing_inside expected_ty+ ; return (idHsWrapper, res) }+ | otherwise+ = do { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise expected_ty+ ; let skol_info = SigSkol ctxt expected_ty tv_prs+ ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs)++ ; let skol_tvs = map snd tv_prs+ ; (ev_binds, result)+ <- checkConstraints skol_info skol_tvs given $+ thing_inside rho_ty++ ; return (wrap <.> mkWpLet ev_binds, result) }+ -- The ev_binds returned by checkConstraints is very+ -- often empty, in which case mkWpLet is a no-op++deeplySkolemise :: TcSigmaType+ -> TcM ( HsWrapper+ , [(Name,TyVar)] -- All skolemised variables+ , [EvVar] -- All "given"s+ , TcRhoType )+-- See Note [Deep skolemisation]+deeplySkolemise ty+ = go init_subst ty+ where+ init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++ go subst ty+ | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty+ = do { let arg_tys' = substScaledTys subst arg_tys+ ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys'+ ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+ ; ev_vars1 <- newEvVars (substTheta subst' theta)+ ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'+ ; let tv_prs1 = map tyVarName tvs `zip` tvs1+ ; return ( mkWpLams ids1+ <.> mkWpTyLams tvs1+ <.> mkWpLams ev_vars1+ <.> wrap+ <.> mkWpEvVarApps ids1+ , tv_prs1 ++ tvs_prs2+ , ev_vars1 ++ ev_vars2+ , mkVisFunTys arg_tys' rho ) }++ | otherwise+ = return (idHsWrapper, [], [], substTy subst ty)+ -- substTy is a quick no-op on an empty substitution++deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)+deeplyInstantiate orig ty+ = go init_subst ty+ where+ init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++ go subst ty+ | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty+ = do { (subst', tvs') <- newMetaTyVarsX subst tvs+ ; let arg_tys' = substScaledTys subst' arg_tys+ theta' = substTheta subst' theta+ ; ids1 <- newSysLocalIds (fsLit "di") arg_tys'+ ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'+ ; (wrap2, rho2) <- go subst' rho+ ; return (mkWpLams ids1+ <.> wrap2+ <.> wrap1+ <.> mkWpEvVarApps ids1,+ mkVisFunTys arg_tys' rho2) }++ | otherwise+ = do { let ty' = substTy subst ty+ ; return (idHsWrapper, ty') }++tcDeepSplitSigmaTy_maybe+ :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType)+-- Looks for a *non-trivial* quantified type, under zero or more function arrows+-- By "non-trivial" we mean either tyvars or constraints are non-empty++tcDeepSplitSigmaTy_maybe ty+ | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty+ , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty+ = Just (arg_ty:arg_tys, tvs, theta, rho)++ | (tvs, theta, rho) <- tcSplitSigmaTy ty+ , not (null tvs && null theta)+ = Just ([], tvs, theta, rho)++ | otherwise = Nothing+++{- *********************************************************************+* * Generalisation * * ********************************************************************* -} {- Note [Skolemisation] ~~~~~~~~~~~~~~~~~~~~~~~-tcSkolemise takes "expected type" and strip off quantifiers to expose the+tcTopSkolemise takes "expected type" and strip off quantifiers to expose the type underneath, binding the new skolems for the 'thing_inside' The returned 'HsWrapper' has type (specific_ty -> expected_ty). @@ -846,29 +1221,35 @@ * It deals specially with just the outer forall, bringing those type variables into lexical scope. To my surprise, I found that doing- this unconditionally in tcSkolemise (i.e. doing it even if we don't+ this unconditionally in tcTopSkolemise (i.e. doing it even if we don't need to bring the variables into lexical scope, which is harmless) caused a non-trivial (1%-ish) perf hit on the compiler. +* It handles deep subumption, wheres tcTopSkolemise never looks under+ function arrows.+ * It always calls checkConstraints, even if there are no skolem variables at all. Reason: there might be nested deferred errors that must not be allowed to float to top level. See Note [When to build an implication] below. -} -tcSkolemise, tcSkolemiseScoped+tcTopSkolemise, tcSkolemiseScoped :: UserTypeCtxt -> TcSigmaType -> (TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- See Note [Skolemisation] for the differences between--- tcSkolemiseScoped and tcSkolemise+-- tcSkolemiseScoped and tcTopSkolemise 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 { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; let skolemise | deep_subsumption = deeplySkolemise+ | otherwise = topSkolemise+ ; (wrap, tv_prs, given, rho_ty) <- skolemise expected_ty + ; let skol_tvs = map snd tv_prs+ skol_info = SigSkol ctxt expected_ty tv_prs ; (ev_binds, res) <- checkConstraints skol_info skol_tvs given $ tcExtendNameTyVarEnv tv_prs $@@ -876,33 +1257,36 @@ ; return (wrap <.> mkWpLet ev_binds, res) } -tcSkolemise ctxt expected_ty thing_inside+tcTopSkolemise ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case = do { res <- thing_inside expected_ty ; return (idHsWrapper, res) } | otherwise- = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty-- ; let skol_tvs = map snd tv_prs- skol_info = SigSkol ctxt expected_ty tv_prs+ = do { rec { let skol_info = SigSkol ctxt expected_ty tv_prs+ ; (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty+ } - ; (ev_binds, result)- <- checkConstraints skol_info skol_tvs given $- thing_inside rho_ty+ ; let skol_tvs = map snd tv_prs+ ; (ev_binds, result)+ <- checkConstraints skol_info skol_tvs given $+ thing_inside rho_ty - ; return (wrap <.> mkWpLet ev_binds, result) }- -- The ev_binds returned by checkConstraints is very- -- often empty, in which case mkWpLet is a no-op+ ; return (wrap <.> mkWpLet ev_binds, result) }+ -- The ev_binds returned by checkConstraints is very+ -- often empty, in which case mkWpLet is a no-op --- | Variant of 'tcSkolemise' that takes an ExpType-tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType- -> (ExpRhoType -> TcM result)- -> TcM (HsWrapper, result)-tcSkolemiseET _ et@(Infer {}) thing_inside+-- | Variant of 'tcTopSkolemise' that takes an ExpType+tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType+ -> (ExpRhoType -> TcM result)+ -> TcM (HsWrapper, result)+tcSkolemiseExpType _ et@(Infer {}) thing_inside = (idHsWrapper, ) <$> thing_inside et-tcSkolemiseET ctxt (Check ty) thing_inside- = tcSkolemise ctxt ty $ \rho_ty ->- thing_inside (mkCheckExpType rho_ty)+tcSkolemiseExpType ctxt (Check ty) thing_inside+ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; let skolemise | deep_subsumption = tcDeeplySkolemise+ | otherwise = tcTopSkolemise+ ; skolemise ctxt ty $ \rho_ty ->+ thing_inside (mkCheckExpType rho_ty) } checkConstraints :: SkolemInfo -> [TcTyVar] -- Skolems@@ -921,7 +1305,7 @@ ; return (ev_binds, result) } else -- Fast path. We check every function argument with tcCheckPolyExpr,- -- which uses tcSkolemise and hence checkConstraints.+ -- which uses tcTopSkolemise and hence checkConstraints. -- So this fast path is well-exercised do { res <- thing_inside ; return (emptyTcEvBinds, res) } }
GHC/Tc/Validity.hs view
@@ -27,7 +27,7 @@ import GHC.Data.Maybe -- friends:-import GHC.Tc.Utils.Unify ( tcSubTypeSigma )+import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) import GHC.Core.TyCo.FVs@@ -139,7 +139,9 @@ and implicit parameter (see Note [Implicit parameters and ambiguity]). And this is what checkAmbiguity does. -What about this, though?+Note [The squishiness of the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What about this? g :: C [a] => Int Is every call to 'g' ambiguous? After all, we might have instance C [a] where ...@@ -150,6 +152,17 @@ and now a call could be legal after all! Well, we'll reject this unless the instance is available *here*. +But even that's not quite right. Even a function with an utterly-ambiguous+type like f :: Eq a => Int -> Int+is still callable if you are prepared to use visible type application,+thus (f @Bool x).++In short, the ambiguity check is a good-faith attempt to say "you are likely+to have trouble if your function has this type"; it is NOT the case that+"you can't call this function without giving a type error".++See also Note [Ambiguity check and deep subsumption] in GHC.Tc.Utils.Unify.+ Note [When to call checkAmbiguity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We call checkAmbiguity@@ -218,7 +231,9 @@ ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $- tcSubTypeSigma ctxt ty ty+ tcSubTypeAmbiguity ctxt ty ty+ -- See Note [Ambiguity check and deep subsumption]+ -- in GHC.Tc.Utils.Unify ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) }
GHC/Types/Demand.hs view
@@ -60,7 +60,7 @@ -- * Demand signatures StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, splitStrictSig, strictSigDmdEnv, hasDemandEnvSig,- nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd,+ nopSig, botSig, isTopSig, isDeadEndSig, isDeadEndAppSig, -- ** Handling arity adjustments prependArgsStrictSig, etaConvertStrictSig, @@ -1468,15 +1468,15 @@ isDeadEndSig :: StrictSig -> Bool isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res --- | Returns true if an application to n args would diverge or throw an+-- | Returns true if an application to n value args would diverge or throw an -- exception. -- -- If a function having 'botDiv' is applied to a less number of arguments than -- its syntactic arity, we cannot say for sure that it is going to diverge. -- Hence this function conservatively returns False in that case. -- See Note [Dead ends].-appIsDeadEnd :: StrictSig -> Int -> Bool-appIsDeadEnd (StrictSig (DmdType _ ds res)) n+isDeadEndAppSig :: StrictSig -> Int -> Bool+isDeadEndAppSig (StrictSig (DmdType _ ds res)) n = isDeadEndDiv res && not (lengthExceeds ds n) prependArgsStrictSig :: Int -> StrictSig -> StrictSig
GHC/Unit/Module/Graph.hs view
@@ -72,9 +72,9 @@ -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode]- , mg_non_boot :: ModuleEnv ModSummary+ , mg_non_boot :: !(ModuleEnv ModSummary) -- a map of all non-boot ModSummaries keyed by Modules- , mg_boot :: ModuleSet+ , mg_boot :: !ModuleSet -- a set of boot Modules , mg_needs_th_or_qq :: !Bool -- does any of the modules in mg_mss require TemplateHaskell or
ghc.cabal view
@@ -3,7 +3,7 @@ Cabal-Version: 1.22 Name: ghc-Version: 9.2.3.20220620+Version: 9.2.4 License: BSD3 License-File: LICENSE Author: The GHC Team@@ -71,9 +71,9 @@ hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*,- ghc-boot == 9.2.3.20220620,- ghc-heap == 9.2.3.20220620,- ghci == 9.2.3.20220620+ ghc-boot == 9.2.4,+ ghc-heap == 9.2.4,+ ghci == 9.2.4 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13