ghc 8.8.1 → 8.8.3

raw patch · 40 files changed

+1663/−782 lines, 40 filesdep ~ghc-bootdep ~ghc-boot-thdep ~ghc-heapPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-boot, ghc-boot-th, ghc-heap, ghci

API changes (from Hackage documentation)

Files

• autogen/Config.hs +5/−5
• cmm/MkGraph.hs +2/−2
• codeGen/StgCmmClosure.hs +6/−7
• codeGen/StgCmmExpr.hs +193/−19
• coreSyn/CorePrep.hs +7/−15
• coreSyn/CoreUtils.hs +2/−0
• deSugar/Check.hs +20/−27
• ghc.cabal +6/−6
• ghci/RtClosureInspect.hs +2/−2
• hsSyn/HsUtils.hs +45/−40
• iface/IfaceSyn.hs +1/−1
• iface/TcIface.hs +1/−1
• llvmGen/LlvmCodeGen.hs +14/−14
• llvmGen/LlvmCodeGen/Base.hs +28/−15
• main/DriverPipeline.hs +5/−5
• main/GHC.hs +4/−0
• main/SysTools/Process.hs +23/−4
• main/SysTools/Tasks.hs +5/−13
• nativeGen/AsmCodeGen.hs +30/−17
• nativeGen/BlockLayout.hs +15/−13
• nativeGen/CFG.hs +54/−24
• nativeGen/Dwarf/Types.hs +2/−1
• nativeGen/NCGMonad.hs +11/−4
• nativeGen/RegAlloc/Liveness.hs +1/−1
• nativeGen/X86/CodeGen.hs +473/−203
• nativeGen/X86/Instr.hs +3/−1
• parser/Parser.hs +1/−0
• simplCore/OccurAnal.hs +15/−5
• typecheck/TcBackpack.hs +1/−1
• typecheck/TcBinds.hs +7/−5
• typecheck/TcRnDriver.hs +7/−6
• typecheck/TcRnExports.hs +4/−4
• typecheck/TcRnMonad.hs +220/−156
• typecheck/TcSigs.hs +17/−6
• typecheck/TcSimplify.hs +5/−3
• typecheck/TcSplice.hs +125/−133
• typecheck/TcUnify.hs +8/−1
• typecheck/TcValidity.hs +6/−5
• types/TyCoRep.hs +289/−16
• types/Type.hs +0/−1

@@ -19,19 +19,19 @@ cProjectName          :: String cProjectName          = "The Glorious Glasgow Haskell Compilation System" cProjectGitCommitId   :: String-cProjectGitCommitId   = "9c787d4d24f2b515934c8503ee2bbd7cfac4da20"+cProjectGitCommitId   = "d0bab2e3419e49cdbb1201d4650572b57f33420c" cProjectVersion       :: String-cProjectVersion       = "8.8.1"+cProjectVersion       = "8.8.3" cProjectVersionInt    :: String cProjectVersionInt    = "808" cProjectPatchLevel    :: String-cProjectPatchLevel    = "1"+cProjectPatchLevel    = "3" cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "1"+cProjectPatchLevel1   = "3" cProjectPatchLevel2   :: String cProjectPatchLevel2   = "" cBooterVersion        :: String-cBooterVersion        = "8.6.5"+cBooterVersion        = "8.8.3" cStage                :: String cStage                = show (STAGE :: Int) cIntegerLibraryType   :: IntegerLibrary

@@ -151,7 +151,7 @@ catAGraphs     :: [CmmAGraph] -> CmmAGraph catAGraphs      = concatOL --- | created a sequence "goto id; id:" as an AGraph+-- | creates a sequence "goto id; id:" as an AGraph mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph mkLabel bid scp = unitOL (CgLabel bid scp) @@ -159,7 +159,7 @@ mkMiddle        :: CmmNode O O -> CmmAGraph mkMiddle middle = unitOL (CgStmt middle) --- | created a closed AGraph from a given node+-- | creates a closed AGraph from a given node mkLast         :: CmmNode O C -> CmmAGraph mkLast last     = unitOL (CgLast last) 

@@ -355,20 +355,19 @@ --    * big, otherwise. -- -- Small families can have the constructor tag in the tag bits.--- Big families only use the tag value 1 to represent evaluatedness.+-- Big families always use the tag values 1..mAX_PTR_TAG to represent+-- evaluatedness, the last one lumping together all overflowing ones. -- We don't have very many tag bits: for example, we have 2 bits on -- x86-32 and 3 bits on x86-64.+--+-- Also see Note [Tagging big families] in GHC.StgToCmm.Expr  isSmallFamily :: DynFlags -> Int -> Bool isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags  tagForCon :: DynFlags -> DataCon -> DynTag-tagForCon dflags con-  | isSmallFamily dflags fam_size = con_tag-  | otherwise                     = 1-  where-    con_tag  = dataConTag con -- NB: 1-indexed-    fam_size = tyConFamilySize (dataConTyCon con)+tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags)+-- NB: 1-indexed  tagForArity :: DynFlags -> RepArity -> DynTag tagForArity dflags arity

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, BangPatterns #-}  ----------------------------------------------------------------------------- --@@ -32,7 +32,7 @@  import MkGraph import BlockId-import Cmm+import Cmm hiding ( succ ) import CmmInfo import CoreSyn import DataCon@@ -47,10 +47,12 @@ import Util import FastString import Outputable+import DynFlags -import Control.Monad (unless,void)-import Control.Arrow (first)+import Control.Monad ( unless, void )+import Control.Arrow ( first ) import Data.Function ( on )+import Data.List     ( partition )  ------------------------------------------------------------------------ --              cgExpr: the main function@@ -639,30 +641,153 @@          ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts -        ; let fam_sz   = tyConFamilySize tycon-              bndr_reg = CmmLocal (idToReg dflags bndr)+        ; let !fam_sz   = tyConFamilySize tycon+              !bndr_reg = CmmLocal (idToReg dflags bndr)+              !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+              !branches' = first succ <$> branches+              !maxpt = mAX_PTR_TAG dflags+              (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'+              !small = isSmallFamily dflags fam_sz -                    -- Is the constructor tag in the node reg?-        ; if isSmallFamily dflags fam_sz-          then do-                let   -- Yes, bndr_reg has constr. tag in ls bits-                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)-                   branches' = [(tag+1,branch) | (tag,branch) <- branches]-                emitSwitch tag_expr branches' mb_deflt 1 fam_sz+                -- Is the constructor tag in the node reg?+                -- See Note [Tagging big families]+        ; if small || null via_info+           then -- Yes, bndr_reg has constructor tag in ls bits+               emitSwitch ptag_expr branches' mb_deflt 1+                 (if small then fam_sz else maxpt) -           else -- No, get tag from info table-                let -- Note that ptr _always_ has tag 1-                    -- when the family size is big enough-                    untagged_ptr = cmmRegOffB bndr_reg (-1)-                    tag_expr = getConstrTag dflags (untagged_ptr)-                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)+           else -- No, the get exact tag from info table when mAX_PTR_TAG+                -- See Note [Double switching for big families]+              do+                let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)+                    !itag_expr = getConstrTag dflags untagged_ptr+                    !info0 = first pred <$> via_info+                if null via_ptr then+                  emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)+                else do+                  infos_lbl <- newBlockId+                  infos_scp <- getTickScope +                  let spillover = (maxpt, (mkBranch infos_lbl, infos_scp))++                  (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of+                      (Just (stmts, scp)) ->+                          do lbl <- newBlockId+                             return ( Just (mkLabel lbl scp <*> stmts, scp)+                                    , Just (mkBranch lbl, scp))+                      _ -> return (Nothing, Nothing)+                  -- Switch on pointer tag+                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt+                  join_lbl <- newBlockId+                  emit (mkBranch join_lbl)+                  -- Switch on info table tag+                  emitLabel infos_lbl+                  emitSwitch itag_expr info0 mb_shared_branch+                    (maxpt - 1) (fam_sz - 1)+                  emitLabel join_lbl+         ; return AssignedDirectly }  cgAlts _ _ _ _ = panic "cgAlts"         -- UbxTupAlt and PolyAlt have only one alternative +-- Note [Double switching for big families]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- An algebraic data type can have a n >= 0 summands+-- (or alternatives), which are identified (labeled) by+-- constructors. In memory they are kept apart by tags+-- (see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure).+-- Due to the characteristics of the platform that+-- contribute to the alignment of memory objects, there+-- is a natural limit of information about constructors+-- that can be encoded in the pointer tag. When the mapping+-- of constructors to the pointer tag range 1..mAX_PTR_TAG+-- is not injective, then we have a "big data type", also+-- called a "big (constructor) family" in the literature.+-- Constructor tags residing in the info table are injective,+-- but considerably more expensive to obtain, due to additional+-- memory access(es).+--+-- When doing case analysis on a value of a "big data type"+-- we need two nested switch statements to make up for the lack+-- of injectivity of pointer tagging, also taking the info+-- table tag into account. The exact mechanism is described next.+--+-- In the general case, switching on big family alternatives+-- is done by two nested switch statements. According to+-- Note [Tagging big families], the outer switch+-- looks at the pointer tag and the inner dereferences the+-- pointer and switches on the info table tag.+--+-- We can handle a simple case first, namely when none+-- of the case alternatives mention a constructor having+-- a pointer tag of 1..mAX_PTR_TAG-1. In this case we+-- simply emit a switch on the info table tag.+-- Note that the other simple case is when all mentioned+-- alternatives lie in 1..mAX_PTR_TAG-1, in which case we can+-- switch on the ptr tag only, just like in the small family case.+--+-- There is a single intricacy with a nested switch:+-- Both should branch to the same default alternative, and as such+-- avoid duplicate codegen of potentially heavy code. The outer+-- switch generates the actual code with a prepended fresh label,+-- while the inner one only generates a jump to that label.+--+-- For example, let's assume a 64-bit architecture, so that all+-- heap objects are 8-byte aligned, and hence the address of a+-- heap object ends in `000` (three zero bits).+--+-- Then consider the following data type+--+--   > data Big = T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8+--   Ptr tag:      1    2    3    4    5    6    7    7    7+--   As bits:    001  010  011  100  101  110  111  111  111+--   Info pointer tag (zero based):+--                 0    1    2    3    4    5    6    7    8+--+-- Then     \case T2 -> True; T8 -> True; _ -> False+-- will result in following code (slightly cleaned-up and+-- commented -ddump-cmm-from-stg):+{-+           R1 = _sqI::P64;  -- scrutinee+           if (R1 & 7 != 0) goto cqO; else goto cqP;+       cqP: // global       -- enter+           call (I64[R1])(R1) returns to cqO, args: 8, res: 8, upd: 8;+       cqO: // global       -- already WHNF+           _sqJ::P64 = R1;+           _cqX::P64 = _sqJ::P64 & 7;  -- extract pointer tag+           switch [1 .. 7] _cqX::P64 {+               case 3 : goto cqW;+               case 7 : goto cqR;+               default: {goto cqS;}+           }+       cqR: // global+           _cr2 = I32[I64[_sqJ::P64 & (-8)] - 4]; -- tag from info pointer+           switch [6 .. 8] _cr2::I64 {+               case 8 : goto cr1;+               default: {goto cr0;}+           }+       cr1: // global+           R1 = GHC.Types.True_closure+2;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+       cr0: // global     -- technically necessary label+           goto cqS;+       cqW: // global+           R1 = GHC.Types.True_closure+2;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+       cqS: // global+           R1 = GHC.Types.False_closure+1;+           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;+-}+--+-- For 32-bit systems we only have 2 tag bits in the pointers at our disposal,+-- so the performance win is dubious, especially in face of the increased code+-- size due to double switching. But we can take the viewpoint that 32-bit+-- architectures are not relevant for performance any more, so this can be+-- considered as moot. + -- Note [alg-alt heap check] -- -- In an algebraic case with more than one alternative, we will have@@ -682,6 +807,55 @@ -- L5: --   x = R1 --   goto L1+++-- Note [Tagging big families]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Both the big and the small constructor families are tagged,+-- that is, greater unions which overflow the tag space of TAG_BITS+-- (i.e. 3 on 32 resp. 7 constructors on 64 bit archs).+--+-- For example, let's assume a 64-bit architecture, so that all+-- heap objects are 8-byte aligned, and hence the address of a+-- heap object ends in `000` (three zero bits).  Then consider+-- > data Maybe a = Nothing | Just a+-- > data Day a = Mon | Tue | Wed | Thu | Fri | Sat | Sun+-- > data Grade = G1 | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10+--+-- Since `Grade` has more than 7 constructors, it counts as a+-- "big data type" (also referred to as "big constructor family" in papers).+-- On the other hand, `Maybe` and `Day` have 7 constructors or fewer, so they+-- are "small data types".+--+-- Then+--   * A pointer to an unevaluated thunk of type `Maybe Int`, `Day` or `Grade` will end in `000`+--   * A tagged pointer to a `Nothing`, `Mon` or `G1` will end in `001`+--   * A tagged pointer to a `Just x`, `Tue` or `G2`  will end in `010`+--   * A tagged pointer to `Wed` or `G3` will end in `011`+--       ...+--   * A tagged pointer to `Sat` or `G6` will end in `110`+--   * A tagged pointer to `Sun` or `G7` or `G8` or `G9` or `G10` will end in `111`+--+-- For big families we employ a mildly clever way of combining pointer and+-- info-table tagging. We use 1..MAX_PTR_TAG-1 as pointer-resident tags where+-- the tags in the pointer and the info table are in a one-to-one+-- relation, whereas tag MAX_PTR_TAG is used as "spill over", signifying+-- we have to fall back and get the precise constructor tag from the+-- info-table.+--+-- Consequently we now cascade switches, because we have to check+-- the pointer tag first, and when it is MAX_PTR_TAG, fetch the precise+-- tag from the info table, and switch on that. The only technically+-- tricky part is that the default case needs (logical) duplication.+-- To do this we emit an extra label for it and branch to that from+-- the second switch. This avoids duplicated codegen. See Trac #14373.+-- See note [Double switching for big families] for the mechanics+-- involved.+--+-- Also see note [Data constructor dynamic tags]+-- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging+--  ------------------- cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]

@@ -1141,6 +1141,7 @@  Instead CoreArity.etaExpand gives                 f = /\a -> \y -> let s = h 3 in g s y+ -}  cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs@@ -1161,6 +1162,8 @@     ==> case x of { p -> map f } -} +-- When updating this function, make sure it lines up with+-- CoreUtils.tryEtaReduce! tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _)   | ok_to_eta_reduce f@@ -1180,25 +1183,14 @@     ok bndr (Var arg) = bndr == arg     ok _    _         = False -          -- We can't eta reduce something which must be saturated.+    -- We can't eta reduce something which must be saturated.     ok_to_eta_reduce (Var f) = not (hasNoBinding f)     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise -tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)-  | not (any (`elemVarSet` fvs) bndrs)-  = case tryEtaReducePrep bndrs body of-        Just e -> Just (Let bind e)-        Nothing -> Nothing-  where-    fvs = exprFreeVars r --- NB: do not attempt to eta-reduce across ticks--- Otherwise we risk reducing---       \x. (Tick (Breakpoint {x}) f x)---   ==> Tick (breakpoint {x}) f--- which is bogus (Trac #17228)--- tryEtaReducePrep bndrs (Tick tickish e)---   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e+tryEtaReducePrep bndrs (Tick tickish e)+  | tickishFloatable tickish+  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e  tryEtaReducePrep _ _ = Nothing 

@@ -2338,6 +2338,8 @@ need to address that here. -} +-- When updating this function, make sure to update+-- CorePrep.tryEtaReducePrep as well! tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body   = go (reverse bndrs) body (mkRepReflCo (exprType body))

@@ -51,7 +51,6 @@ import Type import UniqSupply import DsUtils       (isTrueLHsExpr)-import Maybes        (expectJust) import qualified GHC.LanguageExtensions as LangExt  import Data.List     (find)@@ -834,7 +833,7 @@     alts_to_check :: Type -> Type -> [DataCon]                   -> PmM (Either Type (TyCon, [InhabitationCandidate]))     alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of-      Just (tc, _)+      Just (tc, tc_args)         |  tc `elem` trivially_inhabited         -> case dcs of              []    -> return (Left src_ty)@@ -850,7 +849,7 @@            -- them extremely misleading.         -> liftD $ do              var  <- mkPmId core_ty -- it would be wrong to unify x-             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)+             alts <- mapM (mkOneConFull var tc_args . RealDataCon) (tyConDataCons tc)              return $ Right                (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}                     | alt <- alts ])@@ -1610,37 +1609,31 @@  -- | Generate an 'InhabitationCandidate' for a given conlike (generate -- fresh variables of the appropriate type for arguments)-mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate---  *  x :: T tys, where T is an algebraic data type---     NB: in the case of a data family, T is the *representation* TyCon---     e.g.   data instance T (a,b) = T1 a b---       leads to---            data TPair a b = T1 a b  -- The "representation" type---       It is TPair, not T, that is given to mkOneConFull+mkOneConFull :: Id -> [Type] -> ConLike -> DsM InhabitationCandidate+--  * 'con' K is a conlike of algebraic data type 'T tys'++--  * 'tc_args' are the type arguments of the 'con's TyCon T -----  * 'con' K is a conlike of data type T+--  *  'x' is the variable for which we encode an equality constraint+--     in the term oracle ----- After instantiating the universal tyvars of K we get---          K tys :: forall bs. Q => s1 .. sn -> T tys+-- After instantiating the universal tyvars of K to tc_args we get+--          K @tys :: forall bs. Q => s1 .. sn -> T tys -- -- Suppose y1 is a strict field. Then we get -- Results: ic_val_abs:        K (y1::s1) .. (yn::sn) --          ic_tm_ct:          x ~ K y1..yn --          ic_ty_cs:          Q --          ic_strict_arg_tys: [s1]-mkOneConFull x con = do-  let res_ty  = idType x-      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)+mkOneConFull x tc_args con = do+  let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, _con_res_ty)         = conLikeFullSig con       arg_is_banged = map isBanged $ conLikeImplBangs con-      tc_args = tyConAppArgs res_ty-      subst1  = case con of-                  RealDataCon {} -> zipTvSubst univ_tvs tc_args-                  PatSynCon {}   -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)-                                    -- See Note [Pattern synonym result type] in PatSyn+      subst1  = zipTvSubst univ_tvs tc_args    (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM +  -- Field types   let arg_tys' = substTys subst arg_tys   -- Fresh term variables (VAs) as arguments to the constructor   arguments <-  mapM mkPmVar arg_tys'@@ -2068,7 +2061,7 @@           (PmVar x) (ValVec vva delta) = do   (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys) -  cons_cs <- mapM (liftD . mkOneConFull x) complete_match+  cons_cs <- mapM (liftD . mkOneConFull x tys) complete_match    inst_vsa <- flip mapMaybeM cons_cs $       \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct@@ -2165,11 +2158,11 @@   u_1, ..., u_p are the universally quantified type variables.  In the ConVar case, the coverage algorithm will have in hand the constructor-K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p-are some types that instantiate u_1, ... u_p. The idea is that we should-substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the-mkOneConFull function accomplishes this) and then hand this PmCon off to the-ConCon case.+K as well as a list of type arguments [t_1, ..., t_n] to substitute T's+universally quantified type variables u_1, ..., u_n for. It's crucial to take+these in as arguments, as it is non-trivial to derive them just from the result+type of a pattern synonym and the ambient type of the match (#11336, #17112).+The type checker already did the hard work, so we should just make use of it.  The presence of existentially quantified type variables adds a significant wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,

@@ -1,6 +1,6 @@ Cabal-Version: 2.0 Name: ghc-Version: 8.8.1+Version: 8.8.3  License: BSD3 License-File: LICENSE@@ -65,7 +65,7 @@ Library     -- The generated code in autogen/ has been generated for a linux/x86_64 target     -- So everything else is definitely not working...-    if !(os(linux) && arch(x86_64) && impl(ghc == 8.8.1))+    if !(os(linux) && arch(x86_64) && impl(ghc == 8.8.3))       build-depends: base<0      -- ...while this package may in theory allow to reinstall lib:ghc@@ -93,10 +93,10 @@                    template-haskell == 2.15.*,                    hpc        == 0.6.*,                    transformers == 0.5.*,-                   ghc-boot   == 8.8.1,-                   ghc-boot-th == 8.8.1,-                   ghc-heap   == 8.8.1,-                   ghci == 8.8.1+                   ghc-boot   == 8.8.3,+                   ghc-boot-th == 8.8.3,+                   ghc-heap   == 8.8.3,+                   ghci == 8.8.3      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.7

@@ -765,7 +765,7 @@                         then parens (text "already monomorphic: " <> ppr my_ty)                         else Ppr.empty)         Right dcname <- liftIO $ constrClosToName hsc_env clos-        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)+        (mb_dc, _)   <- tryTc (tcLookupDataCon dcname)         case mb_dc of           Nothing -> do -- This can happen for private constructors compiled -O0                         -- where the .hi descriptor does not export them@@ -981,7 +981,7 @@       ConstrClosure{ptrArgs=pArgs} -> do         Right dcname <- liftIO $ constrClosToName hsc_env clos         traceTR (text "Constr1" <+> ppr dcname)-        (_,mb_dc) <- tryTc (tcLookupDataCon dcname)+        (mb_dc, _) <- tryTc (tcLookupDataCon dcname)         case mb_dc of           Nothing-> do             forM pArgs $ \x -> do

@@ -57,7 +57,7 @@   -- Types   mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs,   mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,-  nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,+  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,    -- Stmts   mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,@@ -105,14 +105,14 @@ import RdrName import Var import TyCoRep-import Type   ( filterOutInvisibleTypes )+import Type   ( tyConArgFlags ) import TysWiredIn ( unitTy ) import TcType import DataCon import ConLike import Id import Name-import NameSet+import NameSet hiding ( unitFV ) import NameEnv import BasicTypes import SrcLoc@@ -121,7 +121,6 @@ import Bag import Outputable import Constants-import TyCon  import Data.Either import Data.Function@@ -510,6 +509,10 @@ nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys +nlHsAppKindTy ::+  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)+nlHsAppKindTy f k = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))+ {- Tuples.  All these functions are *pre-typechecker* because they lack types on the tuple.@@ -669,14 +672,24 @@     go (LitTy (StrTyLit s))       = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)     go ty@(TyConApp tc args)-      | any isInvisibleTyConBinder (tyConBinders tc)+      | tyConAppNeedsKindSig True tc (length args)         -- We must produce an explicit kind signature here to make certain         -- programs kind-check. See Note [Kind signatures in typeToLHsType].       = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))       | otherwise = lhs_ty        where-        lhs_ty = nlHsTyConApp (getRdrName tc) (map go args')-        args'  = filterOutInvisibleTypes tc args+        arg_flags :: [ArgFlag]+        arg_flags = tyConArgFlags tc args++        lhs_ty :: LHsType GhcPs+        lhs_ty = foldl' (\f (arg, flag) ->+                          let arg' = go arg in+                          case flag of+                            Inferred  -> f+                            Specified -> f `nlHsAppKindTy` arg'+                            Required  -> f `nlHsAppTy`     arg')+                        (nlHsTyVar (getRdrName tc))+                        (zip args arg_flags)     go (CastTy ty _)        = go ty     go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co) @@ -693,48 +706,40 @@ There are types that typeToLHsType can produce which require explicit kind signatures in order to kind-check. Here is an example from Trac #14579: -  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) deriving Eq-  newtype Glurp a = MkGlurp (Wat ('Proxy :: Proxy a)) deriving Eq+  -- type P :: forall {k} {t :: k}. Proxy t+  type P = 'Proxy +  -- type Wat :: forall a. Proxy a -> *+  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)+    deriving Eq++  -- type Wat2 :: forall {a}. Proxy a -> *+  type Wat2 = Wat++  -- type Glurp :: * -> *+  newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))+    deriving Eq+ The derived Eq instance for Glurp (without any kind signatures) would be:    instance Eq a => Eq (Glurp a) where-    (==) = coerce @(Wat 'Proxy -> Wat 'Proxy -> Bool)-                  @(Glurp a    -> Glurp a    -> Bool)+    (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)+                  @(Glurp a -> Glurp a -> Bool)                   (==) :: Glurp a -> Glurp a -> Bool  (Where the visible type applications use types produced by typeToLHsType.) -The type 'Proxy has an underspecified kind, so we must ensure that-typeToLHsType ascribes it with its kind: ('Proxy :: Proxy a).--We must be careful not to produce too many kind signatures, or else-typeToLHsType can produce noisy types like-('Proxy :: Proxy (a :: (Type :: Type))). In pursuit of this goal, we adopt the-following criterion for choosing when to annotate types with kinds:--* If there is a tycon application with any invisible arguments, annotate-  the tycon application with its kind.--Why is this the right criterion? The problem we encountered earlier was the-result of an invisible argument (the `a` in ('Proxy :: Proxy a)) being-underspecified, so producing a kind signature for 'Proxy will catch this.-If there are no invisible arguments, then there is nothing to do, so we can-avoid polluting the result type with redundant noise.--What about a more complicated tycon, such as this?--  T :: forall {j} (a :: j). a -> Type--Unlike in the previous 'Proxy example, annotating an application of `T` to an-argument (e.g., annotating T ty to obtain (T ty :: Type)) will not fix-its invisible argument `j`. But because we apply this strategy recursively,-`j` will be fixed because the kind of `ty` will be fixed! That is to say,-something to the effect of (T (ty :: j) :: Type) will be produced.+The type P (in Wat2 P) has an underspecified kind, so we must ensure that+typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish+this, whenever we see an application of a tycon to some arguments, we use+the tyConAppNeedsKindSig function to determine if it requires an explicit kind+signature to resolve some ambiguity. (See Note+Note [When does a tycon application need an explicit kind signature?] for a+more detailed explanation of how this works.) -This strategy certainly isn't foolproof, as tycons that contain type families-in their kind might break down. But we'd likely need visible kind application-to make those work.+Note that we pass True to tyConAppNeedsKindSig since we are generated code with+visible kind applications, so even specified arguments count towards injective+positions in the kind of the tycon. -}  {- *********************************************************************

@@ -1114,7 +1114,7 @@     --    [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.)     ppr_tc_app gadt_subst =       pprPrefixIfDeclBndr how_much (occName tycon)-      <+> pprIfaceAppArgs+      <+> pprParendIfaceAppArgs             (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders))      mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs

@@ -1365,7 +1365,7 @@     -- If debug flag is not set: Ignore source notes     dbgLvl <- fmap debugLevel getDynFlags     case tickish of-      IfaceSource{} | dbgLvl > 0+      IfaceSource{} | dbgLvl == 0                     -> return expr'       _otherwise    -> do         tickish' <- tcIfaceTickish tickish

@@ -1,9 +1,9 @@-{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns, OverloadedStrings #-}  -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. ---module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where+module LlvmCodeGen ( LlvmVersion, llvmVersionList, llvmCodeGen, llvmFixupAsm ) where  #include "HsVersions.h" @@ -34,7 +34,7 @@ import SysTools ( figureLlvmVersion ) import qualified Stream -import Control.Monad ( when )+import Control.Monad ( when, forM_ ) import Data.Maybe ( fromMaybe, catMaybes ) import System.IO @@ -52,21 +52,21 @@        showPass dflags "LLVM CodeGen"         -- get llvm version, cache for later use-       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags+       mb_ver <- figureLlvmVersion dflags         -- warn if unsupported-       debugTraceMsg dflags 2-            (text "Using LLVM version:" <+> text (show ver))-       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags-       when (ver /= supportedLlvmVersion && doWarn) $-           putMsg dflags (text "You are using an unsupported version of LLVM!"-                            $+$ text ("Currently only " ++-                                      llvmVersionStr supportedLlvmVersion ++-                                      " is supported.")-                            $+$ text "We will try though...")+       forM_ mb_ver $ \ver -> do+         debugTraceMsg dflags 2+              (text "Using LLVM version:" <+> text (llvmVersionStr ver))+         let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+         when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $+           "You are using an unsupported version of LLVM!" $$+           "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+>+           "System LLVM version: " <> text (llvmVersionStr ver) $$+           "We will try though..."         -- run code generation-       runLlvm dflags ver bufh us $+       runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh us $          llvmCodeGen' (liftStream cmm_stream)         bFlush bufh

@@ -12,7 +12,8 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion (..), supportedLlvmVersion, llvmVersionStr,+        LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion,+        llvmVersionStr, llvmVersionList,          LlvmM,         runLlvm, liftStream, withClearVars, varLookup, varInsert,@@ -58,6 +59,9 @@ import qualified Stream  import Control.Monad (ap)+import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE  -- ---------------------------------------------------------------------------- -- * Some Data Types@@ -175,26 +179,35 @@ -- * Llvm Version -- --- | LLVM Version Number-data LlvmVersion-    = LlvmVersion Int-    | LlvmVersionOld Int Int-    deriving Eq+-- Newtype to avoid using the Eq instance!+newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } --- Custom show instance for backwards compatibility.-instance Show LlvmVersion where-  show (LlvmVersion maj) = show maj-  show (LlvmVersionOld maj min) = show maj ++ "." ++ show min+parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+  where+    go vs s+      | null ver_str+      = reverse vs+      | '.' : rest' <- rest+      = go (read ver_str : vs) rest'+      | otherwise+      = reverse (read ver_str : vs)+      where+        (ver_str, rest) = span isDigit s  -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION+supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| []) +llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION+ llvmVersionStr :: LlvmVersion -> String-llvmVersionStr v =-  case v of-    LlvmVersion maj -> show maj-    LlvmVersionOld maj min -> show maj ++ "." ++ show min+llvmVersionStr = intercalate "." . map show . llvmVersionList++llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE  -- ---------------------------------------------------------------------------- -- * Environment Handling

@@ -56,7 +56,7 @@ import BasicTypes       ( SuccessFlag(..) ) import Maybes           ( expectJust ) import SrcLoc-import LlvmCodeGen      ( LlvmVersion (..), llvmFixupAsm )+import LlvmCodeGen      ( llvmFixupAsm, llvmVersionList ) import MonadUtils import Platform import TcRnTypes@@ -2170,10 +2170,10 @@ getBackendDefs :: DynFlags -> IO [String] getBackendDefs dflags | hscTarget dflags == HscLlvm = do     llvmVer <- figureLlvmVersion dflags-    return $ case llvmVer of-               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]-               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _      -> []+    return $ case fmap llvmVersionList llvmVer of+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+               _ -> []   where     format (major, minor)       | minor >= 100 = error "getBackendDefs: Unsupported minor version"

@@ -80,6 +80,7 @@         modInfoIsExportedName,         modInfoLookupName,         modInfoIface,+        modInfoRdrEnv,         modInfoSafe,         lookupGlobalName,         findGlobalAnns,@@ -1220,6 +1221,9 @@  modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface++modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv+modInfoRdrEnv = minf_rdr_env  -- | Retrieve module safe haskell mode modInfoSafe :: ModuleInfo -> SafeHaskellMode

@@ -68,7 +68,7 @@     -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) readProcessEnvWithExitCode prog args env_update = do     current_env <- getEnvironment-    readCreateProcessWithExitCode (proc prog args) {+    readCreateProcessWithExitCode ((proc prog args) {use_process_jobs = True}) {         env = Just (replaceVar env_update current_env) } ""  -- Don't let gcc localize version info string, #8825@@ -83,16 +83,22 @@   if null b_dirs      then return Nothing      else do env <- getEnvironment-             return (Just (map mangle_path env))+             return (Just (mangle_paths env))  where   (b_dirs, _) = partitionWith get_b_opt opts    get_b_opt (Option ('-':'B':dir)) = Left dir   get_b_opt other = Right other +  -- Work around #1110 on Windows only (lest we stumble into #17266).+#if defined(mingw32_HOST_OS)+  mangle_paths = map mangle_path   mangle_path (path,paths) | map toUpper path == "PATH"         = (path, '\"' : head b_dirs ++ "\";" ++ paths)   mangle_path other = other+#else+  mangle_paths = id+#endif   -----------------------------------------------------------------------------@@ -214,8 +220,21 @@   -- unless an exception was raised.   let safely inner = mask $ \restore -> do         -- acquire-        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $-          runInteractiveProcess pgm real_args mb_cwd mb_env+        -- On Windows due to how exec is emulated the old process will exit and+        -- a new process will be created. This means waiting for termination of+        -- the parent process will get you in a race condition as the child may+        -- not have finished yet.  This caused #16450.  To fix this use a+        -- process job to track all child processes and wait for each one to+        -- finish.+        let procdata = (proc pgm real_args) { cwd = mb_cwd+                                            , env = mb_env+                                            , use_process_jobs = True+                                            , std_in  = CreatePipe+                                            , std_out = CreatePipe+                                            , std_err = CreatePipe+                                            }+        (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $+          createProcess_ "builderMainLoop" procdata         let cleanup_handles = do               hClose hStdIn               hClose hStdOut

@@ -15,14 +15,13 @@ import Platform import Util -import Data.Char import Data.List  import System.IO import System.Process import GhcPrelude -import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion)+import LlvmCodeGen.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion)  import SysTools.Process import SysTools.Info@@ -193,7 +192,7 @@       -- of the options they've specified. llc doesn't care what other       -- options are specified when '-version' is used.       args' = args ++ ["-version"]-  ver <- catchIO (do+  catchIO (do               (pin, pout, perr, _) <- runInteractiveProcess pgm args'                                               Nothing Nothing               {- > llc -version@@ -203,18 +202,12 @@               -}               hSetBinaryMode pout False               _     <- hGetLine pout-              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout-              v     <- case span (/= '.') vline of-                        ("",_)  -> fail "no digits!"-                        (x,"") -> return $ LlvmVersion (read x)-                        (x,y) -> return $ LlvmVersionOld-                                            (read x)-                                            (read $ takeWhile isDigit $ drop 1 y)-+              vline <- hGetLine pout+              let mb_ver = parseLlvmVersion vline               hClose pin               hClose pout               hClose perr-              return $ Just v+              return mb_ver             )             (\err -> do                 debugTraceMsg dflags 2@@ -226,7 +219,6 @@                           text ("Make sure you have installed LLVM " ++                                 llvmVersionStr supportedLlvmVersion) ]                 return Nothing)-  return ver   runLink :: DynFlags -> [Option] -> IO ()

@@ -550,6 +550,10 @@  = do         let platform = targetPlatform dflags +        let proc_name = case cmm of+                (CmmProc _ entry_label _ _) -> ppr entry_label+                _                           -> text "DataChunk"+         -- rewrite assignments to global regs         let fixed_cmm =                 {-# SCC "fixStgRegisters" #-}@@ -579,12 +583,11 @@                 Opt_D_dump_asm_native "Native code"                 (vcat $ map (pprNatCmmDecl ncgImpl) native) -        dumpIfSet_dyn dflags-                Opt_D_dump_cfg_weights "CFG Weights"-                (pprEdgeWeights nativeCfgWeights)+        maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name          -- tag instructions with register liveness information-        -- also drops dead code+        -- also drops dead code. We don't keep the cfg in sync on+        -- some backends, so don't use it there.         let livenessCfg = if (backendMaintainsCfg dflags)                                 then Just nativeCfgWeights                                 else Nothing@@ -697,12 +700,13 @@             cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)          let cfgWithFixupBlks =-                addNodesBetween nativeCfgWeights cfgRegAllocUpdates+                pure addNodesBetween <*> livenessCfg <*> pure cfgRegAllocUpdates          -- Insert stack update blocks-        let postRegCFG =-                foldl' (\m (from,to) -> addImmediateSuccessor from to m )-                       cfgWithFixupBlks stack_updt_blks+        let postRegCFG :: Maybe CFG+            postRegCFG =+                pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m )) <*>+                        cfgWithFixupBlks <*> pure stack_updt_blks          ---- x86fp_kludge.  This pass inserts ffree instructions to clear         ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack@@ -729,11 +733,9 @@                 shortcutBranches dflags ncgImpl tabled postRegCFG          let optimizedCFG =-                optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG+                optimizeCFG (cfgWeightInfo dflags) cmm <$> postShortCFG -        dumpIfSet_dyn dflags-                Opt_D_dump_cfg_weights "CFG Final Weights"-                ( pprEdgeWeights optimizedCFG )+        maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name          --TODO: Partially check validity of the cfg.         let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks@@ -743,8 +745,8 @@                 (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do                 let blocks = concatMap getBlks shorted                 let labels = setFromList $ fmap blockId blocks :: LabelSet-                return $! seq (sanityCheckCfg optimizedCFG labels $-                                text "cfg not in lockstep") ()+                return $! seq (pure sanityCheckCfg <*> optimizedCFG <*> pure labels <*>+                                        pure (text "cfg not in lockstep")) ()          ---- sequence blocks         let sequenced :: [NatCmmDecl statics instr]@@ -761,6 +763,8 @@                 {-# SCC "invertCondBranches" #-}                 map invert sequenced               where+                invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]+                            -> [NatBasicBlock instr]                 invertConds = (invertCondBranches ncgImpl) optimizedCFG                 invert top@CmmData {} = top                 invert (CmmProc info lbl live (ListGraph blocks)) =@@ -793,6 +797,15 @@                 , ppr_raStatsLinear                 , unwinds ) +maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO ()+maybeDumpCfg _dflags Nothing _ _ = return ()+maybeDumpCfg dflags (Just cfg) msg proc_name+        | null cfg = return ()+        | otherwise+        = dumpIfSet_dyn+                dflags Opt_D_dump_cfg_weights msg+                (proc_name <> char ':' $$ pprEdgeWeights cfg)+ -- | Make sure all blocks we want the layout algorithm to place have been placed. checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]             -> [NatCmmDecl statics instr]@@ -917,13 +930,13 @@         :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags         -> NcgImpl statics instr jumpDest         -> [NatCmmDecl statics instr]-        -> CFG-        -> ([NatCmmDecl statics instr],CFG)+        -> Maybe CFG+        -> ([NatCmmDecl statics instr],Maybe CFG)  shortcutBranches dflags ncgImpl tops weights   | gopt Opt_AsmShortcutting dflags   = ( map (apply_mapping ncgImpl mapping) tops'-    , shortcutWeightMap weights mappingBid )+    , shortcutWeightMap mappingBid <$!> weights )   | otherwise   = (tops, weights)   where

@@ -639,29 +639,31 @@  sequenceTop     :: (Instruction instr, Outputable instr)-    => DynFlags --Use new layout code-    -> NcgImpl statics instr jumpDest -> CFG-    -> NatCmmDecl statics instr -> NatCmmDecl statics instr+    => DynFlags -- Determine which layout algo to use+    -> NcgImpl statics instr jumpDest+    -> Maybe CFG -- ^ CFG if we have one.+    -> NatCmmDecl statics instr -- ^ Function to serialize+    -> NatCmmDecl statics instr  sequenceTop _     _       _           top@(CmmData _ _) = top sequenceTop dflags ncgImpl edgeWeights             (CmmProc info lbl live (ListGraph blocks))   | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags   --Use chain based algorithm+  , Just cfg <- edgeWeights   = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                            sequenceChain info edgeWeights blocks )+                            {-# SCC layoutBlocks #-}+                            sequenceChain info cfg blocks )   | otherwise   --Use old algorithm-  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                            sequenceBlocks cfg info blocks)+  = let cfg = if dontUseCfg then Nothing else edgeWeights+    in  CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $+                                {-# SCC layoutBlocks #-}+                                sequenceBlocks cfg info blocks)   where-    cfg-      | (gopt Opt_WeightlessBlocklayout dflags) ||-        (not $ backendMaintainsCfg dflags)-      -- Don't make use of cfg in the old algorithm-      = Nothing-      -- Use cfg in the old algorithm-      | otherwise = Just edgeWeights+    dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||+                 (not $ backendMaintainsCfg dflags)+  -- The old algorithm: -- It is very simple (and stupid): We make a graph out of

@@ -61,8 +61,6 @@  import Data.List --- import qualified Data.IntMap.Strict as M --TODO: LabelMap- type Edge = (BlockId, BlockId) type Edges = [Edge] @@ -76,6 +74,13 @@ type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)  -- | A control flow graph where edges have been annotated with a weight.+-- Implemented as IntMap (IntMap <edgeData>)+-- We must uphold the invariant that for each edge A -> B we must have:+-- A entry B in the outer map.+-- A entry B in the map we get when looking up A.+-- Maintaining this invariant is useful as any failed lookup now indicates+-- an actual error in code which might go unnoticed for a while+-- otherwise. type CFG = EdgeInfoMap EdgeInfo  data CfgEdge@@ -144,12 +149,21 @@   = addEdge from to (info { edgeWeight = f weight}) cfg   | otherwise = cfg + getCfgNodes :: CFG -> LabelSet getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m +-- | Is this block part of this graph? hasNode :: CFG -> BlockId -> Bool-hasNode m node = mapMember node m || any (mapMember node) m+hasNode m node =+  -- Check the invariant that each node must exist in the first map or not at all.+  ASSERT( found || not (any (mapMember node) m))+  found+    where+      found = mapMember node m ++ -- | Check if the nodes in the cfg and the set of blocks are the same. --   In a case of a missmatch we panic and show the difference. sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool@@ -160,7 +174,7 @@         pprPanic "Block list and cfg nodes don't match" (             text "difference:" <+> ppr diff $$             text "blocks:" <+> ppr blockSet $$-            text "cfg:" <+> ppr m $$+            text "cfg:" <+> pprEdgeWeights m $$             msg )             False     where@@ -224,8 +238,8 @@ applies the mapping to the CFG in the way layed out above.  -}-shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG-shortcutWeightMap cfg cuts =+shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG+shortcutWeightMap cuts cfg =   foldl' applyMapping cfg $ mapToList cuts     where -- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]@@ -259,7 +273,7 @@ --             \                  \ --              -> C    =>         -> C ---addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG+addImmediateSuccessor :: HasDebugCallStack => BlockId -> BlockId -> CFG -> CFG addImmediateSuccessor node follower cfg     = updateEdges . addWeightEdge node follower uncondWeight $ cfg     where@@ -275,11 +289,17 @@ -- | Adds a new edge, overwrites existing edges if present addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG addEdge from to info cfg =-    mapAlter addDest from cfg+    mapAlter addFromToEdge from $+    mapAlter addDestNode to cfg     where-        addDest Nothing = Just $ mapSingleton to info-        addDest (Just wm) = Just $ mapInsert to info wm+        -- Simply insert the edge into the edge list.+        addFromToEdge Nothing = Just $ mapSingleton to info+        addFromToEdge (Just wm) = Just $ mapInsert to info wm+        -- We must add the destination node explicitly as well+        addDestNode Nothing = Just $ mapEmpty+        addDestNode n@(Just _) = n + -- | Adds a edge with the given weight to the cfg --   If there already existed an edge it is overwritten. --   `addWeightEdge from to weight cfg`@@ -304,8 +324,11 @@         sortedEdges  -- | Get successors of a given node with edge weights.-getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]-getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid m+getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]+getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m)+  where+    lookupError = pprPanic "getSuccessorEdges: Block does not exist" $+                    ppr bid $$ text "CFG:" <+> pprEdgeWeights m  getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo getEdgeInfo from to m@@ -316,12 +339,13 @@     = Nothing  reverseEdges :: CFG -> CFG-reverseEdges cfg = foldr add mapEmpty flatElems+reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg   where-    elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]-    flatElems =-        concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems-    add (to,from,info) m = addEdge to from info m+    -- We preserve nodes without outgoing edges!+    addNode :: CFG -> BlockId -> CFG+    addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg+    go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG+    go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap  :: CFG  -- | Returns a unordered list of all edges with info infoEdgeList :: CFG -> [CfgEdge]@@ -347,11 +371,14 @@         mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m  -- | Get successors of a given node without edge weights.-getSuccessors :: CFG -> BlockId -> [BlockId]+getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId] getSuccessors m bid     | Just wm <- mapLookup bid m     = mapKeys wm-    | otherwise = []+    | otherwise = lookupError+    where+      lookupError = pprPanic "getSuccessors: Block does not exist" $+                    ppr bid <+> pprEdgeWeights m  pprEdgeWeights :: CFG -> SDoc pprEdgeWeights m =@@ -375,6 +402,7 @@     text "}\n"  {-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible+-- | Invariant: The edge **must** exist already in the graph. updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG updateEdgeWeight f (from, to) cfg     | Just oldInfo <- getEdgeInfo from to cfg@@ -422,7 +450,8 @@         | otherwise         = pprPanic "Can't find weight for edge that should have one" (             text "triple" <+> ppr (from,between,old) $$-            text "updates" <+> ppr updates )+            text "updates" <+> ppr updates $$+            text "cfg:" <+> pprEdgeWeights m )       updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG       updateWeight m (from,between,old,edgeInfo)         = addEdge from between edgeInfo .@@ -550,7 +579,7 @@     blocks = revPostorder graph :: [CmmBlock]  --Find back edges by BFS-findBackEdges :: BlockId -> CFG -> Edges+findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges findBackEdges root cfg =     --pprTraceIt "Backedges:" $     map fst .@@ -562,7 +591,7 @@       classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]  -optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optimizeCFG :: HasDebugCallStack => D.CfgWeights -> RawCmmDecl -> CFG -> CFG optimizeCFG _ (CmmData {}) cfg = cfg optimizeCFG weights (CmmProc info _lab _live graph) cfg =     favourFewerPreds  .@@ -641,16 +670,17 @@ -- | Determine loop membership of blocks based on SCC analysis --   Ideally we would replace this with a variant giving us loop --   levels instead but the SCC code will do for now.-loopMembers :: CFG -> LabelMap Bool+loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool loopMembers cfg =     foldl' (flip setLevel) mapEmpty sccs   where     mkNode :: BlockId -> Node BlockId BlockId     mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)-    nodes = map mkNode (setElems $ getCfgNodes cfg)+    nodes = map mkNode $ setElems (getCfgNodes cfg)      sccs = stronglyConnCompFromEdgedVerticesOrd nodes      setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool     setLevel (AcyclicSCC bid) m = mapInsert bid False m     setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids+

@@ -229,7 +229,8 @@       -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).       -- pad such that first entry begins at multiple of entry size.       pad n = vcat $ replicate n $ pprByte 0-      initialLength = 8 + paddingSize + 2*2*wordSize+      -- Fix for #17428+      initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize   in pprDwWord (ppr initialLength)      $$ pprHalf 2      $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns #-}  -- ----------------------------------------------------------------------------- --@@ -18,7 +20,7 @@         addNodeBetweenNat,         addImmediateSuccessorNat,         updateCfgNat,-        getUniqueNat,+        getUniqueNat, getCfgNat,         mapAccumLNat,         setDeltaNat,         getDeltaNat,@@ -65,6 +67,7 @@ import Outputable (SDoc, pprPanic, ppr) import Cmm (RawCmmDecl, CmmStatics) import CFG+import Util  data NcgImpl statics instr jumpDest = NcgImpl {     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],@@ -88,7 +91,7 @@     -- the block's 'UnwindPoint's     -- See Note [What is this unwinding business?] in Debug     -- and Note [Unwinding information in the NCG] in this module.-    invertCondBranches        :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]+    invertCondBranches        :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]                               -> [NatBasicBlock instr]     -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`     -- when possible.@@ -206,8 +209,12 @@  updateCfgNat :: (CFG -> CFG) -> NatM () updateCfgNat f-        = NatM $ \ st -> ((), st { natm_cfg = f (natm_cfg st) })+        = NatM $ \ st -> let !cfg' = f (natm_cfg st)+                         in ((), st { natm_cfg = cfg'}) +getCfgNat :: NatM CFG+getCfgNat = NatM $ \ st -> (natm_cfg st, st)+ -- | Record that we added a block between `from` and `old`. addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () addNodeBetweenNat from between to@@ -231,7 +238,7 @@  -- | Place `succ` after `block` and change any edges --   block -> X to `succ` -> X-addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()+addImmediateSuccessorNat :: HasDebugCallStack => BlockId -> BlockId -> NatM () addImmediateSuccessorNat block succ         = updateCfgNat (addImmediateSuccessor block succ) 

@@ -705,7 +705,7 @@         reachable :: LabelSet         reachable             | Just cfg <- mcfg-            -- Our CFG only contains reachable nodes by construction.+            -- Our CFG only contains reachable nodes by construction at this point.             = getCfgNodes cfg             | otherwise             = setFromList $ [ node_key node | node <- reachablesG g1 roots ]

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}  -- The default iteration limit is a bit too low for the definitions -- in this module.@@ -36,6 +37,7 @@ import X86.Instr import X86.Cond import X86.Regs+import X86.Ppr (  ) import X86.RegInfo  --TODO: Remove - Just for development/debugging@@ -130,7 +132,57 @@ cmmTopCodeGen (CmmData sec dat) = do   return [CmmData sec (1, dat)]  -- no translation, we just use CmmStatic +{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: [Instr] -> ()+verifyBasicBlock instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (ppr i <+> text "in:" $$ vcat (map ppr instrs))+ basicBlockCodeGen         :: CmmBlock         -> NatM ( [NatBasicBlock Instr]@@ -148,9 +200,10 @@             let line = srcSpanStartLine span; col = srcSpanStartCol span             return $ unitOL $ LOCATION fileId line col name     _ -> return nilOL-  mid_instrs <- stmtsToInstrs id stmts-  tail_instrs <- stmtToInstrs id tail+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (tail_instrs,_) <- stmtToInstrs mid_bid tail   let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  return $! verifyBasicBlock (fromOL instrs)   instrs' <- fold <$> traverse addSpUnwindings instrs   -- code generation may introduce new basic block boundaries, which   -- are indicated by the NEWBLOCK instruction.  We must split up the@@ -180,60 +233,137 @@         else return (unitOL instr) addSpUnwindings instr = return $ unitOL instr -stmtsToInstrs :: BlockId -> [CmmNode e x] -> NatM InstrBlock-stmtsToInstrs bid stmts-   = do instrss <- mapM (stmtToInstrs bid) stmts-        return (concatOL instrss)+{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genCCall is also split into two parts.+One for calls which *won't* change the basic blocks in+which successive instructions will be placed.+A different one for calls which *are* known to change the+basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')+ -- | `bid` refers to the current block and is used to update the CFG --   if new blocks are inserted in the control flow.-stmtToInstrs :: BlockId -> CmmNode e x -> NatM InstrBlock+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block. stmtToInstrs bid stmt = do   dflags <- getDynFlags   is32Bit <- is32BitPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))-    CmmTick {}     -> return nilOL+    CmmUnsafeForeignCall target result_regs args+       -> genCCall dflags is32Bit target result_regs args bid -    CmmUnwind regs -> do-      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)-      case foldMap to_unwind_entry regs of-        tbl | M.null tbl -> return nilOL-            | otherwise  -> do-                lbl <- mkAsmTempLabel <$> getUniqueM-                return $ unitOL $ UNWIND lbl tbl+    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT s))+      CmmTick {}     -> return nilOL -    CmmAssign reg src-      | isFloatType ty         -> assignReg_FltCode format reg src-      | is32Bit && isWord64 ty -> assignReg_I64Code      reg src-      | otherwise              -> assignReg_IntCode format reg src-        where ty = cmmRegType dflags reg-              format = cmmTypeFormat ty+      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)+        case foldMap to_unwind_entry regs of+          tbl | M.null tbl -> return nilOL+              | otherwise  -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl -    CmmStore addr src-      | isFloatType ty         -> assignMem_FltCode format addr src-      | is32Bit && isWord64 ty -> assignMem_I64Code      addr src-      | otherwise              -> assignMem_IntCode format addr src-        where ty = cmmExprType dflags src-              format = cmmTypeFormat ty+      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType dflags reg+                format = cmmTypeFormat ty -    CmmUnsafeForeignCall target result_regs args-       -> genCCall dflags is32Bit target result_regs args bid+      CmmStore addr src+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType dflags src+                format = cmmTypeFormat ty -    CmmBranch id          -> return $ genBranch id+      CmmBranch id          -> return $ genBranch id -    --We try to arrange blocks such that the likely branch is the fallthrough-    --in CmmContFlowOpt. So we can assume the condition is likely false here.-    CmmCondBranch arg true false _ -> genCondBranch bid true false arg-    CmmSwitch arg ids -> do dflags <- getDynFlags-                            genSwitch dflags arg ids-    CmmCall { cml_target = arg-            , cml_args_regs = gregs } -> do-                                dflags <- getDynFlags-                                genJump arg (jumpRegs dflags gregs)-    _ ->-      panic "stmtToInstrs: statement should have been cps'd away"+      --We try to arrange blocks such that the likely branch is the fallthrough+      --in CmmContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> do dflags <- getDynFlags+                              genSwitch dflags arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> do+                                  dflags <- getDynFlags+                                  genJump arg (jumpRegs dflags gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"   jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]@@ -1772,6 +1902,109 @@         updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)         return (cond_code `appOL` code) +{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}++ -- ----------------------------------------------------------------------------- --  Generating C calls @@ -1789,14 +2022,168 @@     -> [CmmFormal]        -- where to put the result     -> [CmmActual]        -- arguments (of mixed type)     -> BlockId      -- The block we are in-    -> NatM InstrBlock+    -> NatM (InstrBlock, Maybe BlockId) --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -+-- First we deal with cases which might introduce new blocks in the stream. --- Unroll memcpy calls if the source and destination pointers are at--- least DWORD aligned and the number of bytes to copy isn't too+genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))+                                           [dst] [addr, n] bid = do+    use_sse2 <- sse2Enabled+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    let platform = targetPlatform dflags+        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)+    (code, lbl) <- op_code dst_r arg amode+    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = case amop of+        -- In the common case where dst_r is a virtual register the+        -- final move should go away, because it's the last use of arg+        -- and the first use of dst_r.+        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ], bid)+        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ], bid)+        -- In these cases we need a new block id, and have to return it so+        -- that later instruction selection can reference it.+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                    , NOT format dst+                                                    ])+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid+  | is32Bit, width == W64 = do+      ChildCode64 vcode rlo <- iselExpr64 src+      use_sse2 <- sse2Enabled+      let rhi     = getHiVRegFromLo rlo+          dst_r   = getRegisterReg platform use_sse2 (CmmLocal dst)+      lbl1 <- getBlockIdNat+      lbl2 <- getBlockIdNat+      let format = if width == W8 then II16 else intFormat width+      tmp_r <- getNewRegNat format++      -- New CFG Edges:+      --  bid -> lbl2+      --  bid -> lbl1 -> lbl2+      --  We also changes edges originating at bid to start at lbl2 instead.+      updateCfgNat (addWeightEdge bid lbl1 110 .+                    addWeightEdge lbl1 lbl2 110 .+                    addImmediateSuccessor bid lbl2)++      -- The following instruction sequence corresponds to the pseudo-code+      --+      --  if (src) {+      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+      --  } else {+      --    dst = 64;+      --  }+      let instrs = vcode `appOL` toOL+               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+                , OR       II32 (OpReg rlo)         (OpReg tmp_r)+                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+                , JXX EQQ    lbl2+                , JXX ALWAYS lbl1++                , NEWBLOCK   lbl1+                , BSF     II32 (OpReg rhi)         dst_r+                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+                , BSF     II32 (OpReg rlo)         tmp_r+                , CMOV NE II32 (OpReg tmp_r)       dst_r+                , JXX ALWAYS lbl2++                , NEWBLOCK   lbl2+                ])+      return (instrs, Just lbl2)++  | otherwise = do+    code_src <- getAnyReg src+    use_sse2 <- sse2Enabled+    let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)++    -- The following insn sequence makes sure 'ctz 0' has a defined value.+    -- starting with Haswell, one could use the TZCNT insn instead.+    let format = if width == W8 then II16 else intFormat width+    src_r <- getNewRegNat format+    tmp_r <- getNewRegNat format+    let instrs = code_src src_r `appOL` toOL+              ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++              [ BSF     format (OpReg src_r) tmp_r+              , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+              , CMOV NE format (OpReg tmp_r) dst_r+              ]) -- NB: We don't need to zero-extend the result for the+                  -- W8/W16 cases because the 'MOV' insn already+                  -- took care of implicitly clearing the upper bits+    return (instrs, Nothing)+  where+    bw = widthInBits width+    platform = targetPlatform dflags++genCCall dflags bits mop dst args bid = do+  instr <- genCCall' dflags bits mop dst args bid+  return (instr, Nothing)++-- genCCall' handles cases not introducing new code blocks.+genCCall'+    :: DynFlags+    -> Bool                     -- 32 bit platform?+    -> ForeignTarget            -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> BlockId      -- The block we are in+    -> NatM InstrBlock++-- Unroll memcpy calls if the number of bytes to copy isn't too -- large.  Otherwise, call C's memcpy.-genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _+genCCall' dflags is32Bit (PrimTarget (MO_Memcpy align)) _          [dst, src, CmmLit (CmmInt n _)] _     | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do         code_dst <- getAnyReg dst@@ -1843,7 +2230,7 @@         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone                    (ImmInteger (n - i)) -genCCall dflags _ (PrimTarget (MO_Memset align)) _+genCCall' dflags _ (PrimTarget (MO_Memset align)) _          [dst,           CmmLit (CmmInt c _),           CmmLit (CmmInt n _)]@@ -1888,14 +2275,14 @@         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone                    (ImmInteger (n - i)) -genCCall _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL-genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL+genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL+genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL         -- barriers compile to no code on x86/x86-64;         -- we keep it this long in order to prevent earlier optimisations. -genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL+genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL -genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =+genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =         case n of             0 -> genPrefetch src $ PREFETCH NTA  format             1 -> genPrefetch src $ PREFETCH Lvl2 format@@ -1916,9 +2303,10 @@                               ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))                   -- prefetch always takes an address -genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do+genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do     let platform = targetPlatform dflags-    let dst_r = getRegisterReg platform False (CmmLocal dst)+    use_sse2 <- sse2Enabled+    let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)     case width of         W64 | is32Bit -> do                ChildCode64 vcode rlo <- iselExpr64 src@@ -1938,7 +2326,7 @@   where     format = intFormat width -genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]          args@[src] bid = do     sse4_2 <- sse4_2Enabled     let platform = targetPlatform dflags@@ -1964,20 +2352,21 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]          args@[src, mask] bid = do     let platform = targetPlatform dflags+    use_sse2 <- sse2Enabled     if isBmi2Enabled dflags         then do code_src  <- getAnyReg src                 code_mask <- getAnyReg mask                 src_r     <- getNewRegNat format                 mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)                 return $ code_src src_r `appOL` code_mask mask_r `appOL`                     (if width == W8 then                          -- The PDEP instruction doesn't take a r/m8@@ -1997,20 +2386,21 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]+genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]          args@[src, mask] bid = do     let platform = targetPlatform dflags+    use_sse2 <- sse2Enabled     if isBmi2Enabled dflags         then do code_src  <- getAnyReg src                 code_mask <- getAnyReg mask                 src_r     <- getNewRegNat format                 mask_r    <- getNewRegNat format-                let dst_r = getRegisterReg platform False (CmmLocal dst)+                let dst_r = getRegisterReg platform use_sse2 (CmmLocal dst)                 return $ code_src src_r `appOL` code_mask mask_r `appOL`                     (if width == W8 then                          -- The PEXT instruction doesn't take a r/m8@@ -2030,19 +2420,19 @@             let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                                            [NoHint] [NoHint]                                                            CmmMayReturn)-            genCCall dflags is32Bit target dest_regs args bid+            genCCall' dflags is32Bit target dest_regs args bid   where     format = intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid+genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid   | is32Bit && width == W64 = do     -- Fallback to `hs_clz64` on i386     targetExpr <- cmmMakeDynamicReference dflags CallReference lbl     let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                            [NoHint] [NoHint]                                            CmmMayReturn)-    genCCall dflags is32Bit target dest_regs args bid+    genCCall' dflags is32Bit target dest_regs args bid    | otherwise = do     code_src <- getAnyReg src@@ -2067,162 +2457,37 @@     format = if width == W8 then II16 else intFormat width     lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid-  | is32Bit, width == W64 = do-      ChildCode64 vcode rlo <- iselExpr64 src-      let rhi     = getHiVRegFromLo rlo-          dst_r   = getRegisterReg platform False (CmmLocal dst)-      lbl1 <- getBlockIdNat-      lbl2 <- getBlockIdNat-      tmp_r <- getNewRegNat format--      -- New CFG Edges:-      --  bid -> lbl2-      --  bid -> lbl1 -> lbl2-      --  We also changes edges originating at bid to start at lbl2 instead.-      updateCfgNat (addWeightEdge bid lbl1 110 .-                    addWeightEdge lbl1 lbl2 110 .-                    addImmediateSuccessor bid lbl2)--      -- The following instruction sequence corresponds to the pseudo-code-      ---      --  if (src) {-      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);-      --  } else {-      --    dst = 64;-      --  }-      return $ vcode `appOL` toOL-               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)-                , OR       II32 (OpReg rlo)         (OpReg tmp_r)-                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)-                , JXX EQQ    lbl2-                , JXX ALWAYS lbl1--                , NEWBLOCK   lbl1-                , BSF     II32 (OpReg rhi)         dst_r-                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)-                , BSF     II32 (OpReg rlo)         tmp_r-                , CMOV NE II32 (OpReg tmp_r)       dst_r-                , JXX ALWAYS lbl2--                , NEWBLOCK   lbl2-                ])--  | otherwise = do-    code_src <- getAnyReg src-    src_r <- getNewRegNat format-    tmp_r <- getNewRegNat format-    let dst_r = getRegisterReg platform False (CmmLocal dst)--    -- The following insn sequence makes sure 'ctz 0' has a defined value.-    -- starting with Haswell, one could use the TZCNT insn instead.-    return $ code_src src_r `appOL` toOL-             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-              [ BSF     format (OpReg src_r) tmp_r-              , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)-              , CMOV NE format (OpReg tmp_r) dst_r-              ]) -- NB: We don't need to zero-extend the result for the-                 -- W8/W16 cases because the 'MOV' insn already-                 -- took care of implicitly clearing the upper bits-  where-    bw = widthInBits width-    platform = targetPlatform dflags-    format = if width == W8 then II16 else intFormat width--genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do+genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do     targetExpr <- cmmMakeDynamicReference dflags                   CallReference lbl     let target = ForeignTarget targetExpr (ForeignConvention CCallConv                                            [NoHint] [NoHint]                                            CmmMayReturn)-    genCCall dflags is32Bit target dest_regs args bid+    genCCall' dflags is32Bit target dest_regs args bid   where     lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))-                                           [dst] [addr, n] bid = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    use_sse2 <- sse2Enabled-    let platform = targetPlatform dflags-        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)-    code <- op_code dst_r arg amode-    return $ addr_code `appOL` arg_code arg `appOL` code-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr)-    op_code dst_r arg amode = case amop of-        -- In the common case where dst_r is a virtual register the-        -- final move should go away, because it's the last use of arg-        -- and the first use of dst_r.-        AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ]-        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)-                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ]-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                    , NOT format dst-                                                    ])-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr)-        cmpxchg_code instrs = do-            lbl <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            addImmediateSuccessorNat bid lbl-            updateCfgNat (addWeightEdge lbl lbl 0)--            return $ toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl-                , NEWBLOCK lbl-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl-                ]--    format = intFormat width--genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do+genCCall' dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do   load_code <- intLoadCode (MOV (intFormat width)) addr   let platform = targetPlatform dflags   use_sse2 <- sse2Enabled+   return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) -genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do+genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do     code <- assignMem_IntCode (intFormat width) addr val     return $ code `snocOL` MFENCE -genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do+genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do     -- On x86 we don't have enough registers to use cmpxchg with a     -- complicated addressing mode, so on that architecture we     -- pre-compute the address first.+    use_sse2 <- sse2Enabled     Amode amode addr_code <- getSimpleAmode dflags is32Bit addr     newval <- getNewRegNat format     newval_code <- getAnyReg new     oldval <- getNewRegNat format     oldval_code <- getAnyReg old-    use_sse2 <- sse2Enabled     let platform = targetPlatform dflags         dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)         code     = toOL@@ -2235,7 +2500,7 @@   where     format = intFormat width -genCCall _ is32Bit target dest_regs args bid = do+genCCall' _ is32Bit target dest_regs args bid = do   dflags <- getDynFlags   let platform = targetPlatform dflags       sse2     = isSse2Enabled dflags@@ -2853,7 +3118,8 @@       let target = ForeignTarget targetExpr                            (ForeignConvention CCallConv [] [] CmmMayReturn) -      stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)+      (instrs, _) <- stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)+      return instrs   where         -- Assume we can call these functions directly, and that they're not in a dynamic library.         -- TODO: Why is this ok? Under linux this code will be in libm.so@@ -3426,10 +3692,14 @@ -- | This works on the invariant that all jumps in the given blocks are required. --   Starting from there we try to make a few more jumps redundant by reordering --   them.-invertCondBranches :: CFG -> LabelMap a -> [NatBasicBlock Instr]+--   We depend on the information in the CFG to do so. Without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks                    -> [NatBasicBlock Instr]-invertCondBranches cfg keep bs =-    --trace "Foo" $+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =     invert bs   where     invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]@@ -3448,7 +3718,7 @@       , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg       -- Both jumps come from the same cmm statement       , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , (CmmSource cmmCondBranch) <- transitionSource edgeInfo1+      , CmmSource cmmCondBranch <- transitionSource edgeInfo1        --Int comparisons are invertable       , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch

@@ -325,7 +325,9 @@                       [Maybe JumpDest] -- Targets of the jump table                       Section   -- Data section jump table should be put in                       CLabel    -- Label of jump table-        | CALL        (Either Imm Reg) [Reg]+        -- | X86 call instruction+        | CALL        (Either Imm Reg) -- ^ Jump target+                      [Reg]            -- ^ Arguments (required for register allocation)          -- Other things.         | CLTD Format            -- sign extend %eax into %edx:%eax

@@ -32,6 +32,7 @@ import Data.Char import Control.Monad    ( mplus ) import Control.Applicative ((<$))+import qualified Prelude  -- compiler/hsSyn import HsSyn

@@ -79,11 +79,16 @@     (final_usage, occ_anald_binds) = go init_env binds     (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel                                                     imp_rule_edges-                                                    (flattenBinds occ_anald_binds)+                                                    (flattenBinds binds)                                                     initial_uds           -- It's crucial to re-analyse the glommed-together bindings           -- so that we establish the right loop breakers. Otherwise-          -- we can easily create an infinite loop (Trac #9583 is an example)+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.      initial_uds = addManyOccsSet emptyDetails                             (rulesFreeVars imp_rules)@@ -2373,9 +2378,14 @@       _               -> (env { occ_encl = OccVanilla }, Nothing)    where-    add_scrut v rhs = ( env { occ_encl = OccVanilla-                            , occ_gbl_scrut = pe `extendVarSet` v }-                      , Just (localise v, rhs) )+    add_scrut v rhs+      | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing)+      | otherwise    = ( env { occ_encl = OccVanilla+                             , occ_gbl_scrut = pe `extendVarSet` v }+                       , Just (localise v, rhs) )+      -- ToDO: this isGlobalId stuff is a TEMPORARY FIX+      --       to avoid the binder-swap for GlobalIds+      --       See Trac #16346      case_bndr' = Var (zapIdOccInfo case_bndr)                    -- See Note [Zap case binders in proxy bindings]

@@ -582,7 +582,7 @@                         -- signatures that are merged in, we will discover this                         -- when we run exports_from_avail on the final merged                         -- export list.-                        (msgs, mb_r) <- tryTc $ do+                        (mb_r, msgs) <- tryTc $ do                             -- Suppose that we have written in a signature:                             --  signature A ( module A ) where {- empty -}                             -- If I am also inheriting a signature from a

@@ -392,14 +392,13 @@            -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)  tcValBinds top_lvl binds sigs thing_inside-  = do  { let patsyns = getPatSynBinds binds--            -- Typecheck the signature+  = do  {   -- Typecheck the signatures+            -- It's easier to do so now, once for all the SCCs together+            -- because a single signature  f,g :: <type>+            -- might relate to more than one SCC         ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $                                 tcTySigs sigs -        ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)-                 -- Extend the envt right away with all the Ids                 -- declared with complete type signatures                 -- Do not extend the TcBinderStack; instead@@ -413,6 +412,9 @@                    ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]                    ; return (extra_binds, thing) }             ; return (binds' ++ extra_binds', thing) }}+  where+    patsyns = getPatSynBinds binds+    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)  ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv

@@ -268,8 +268,10 @@                       ; tcg_env <- tcRnExports explicit_mod_hdr export_ies                                      tcg_env                       ; traceRn "rn4b: after exports" empty-                      ; -- Check main is exported(must be after tcRnExports)-                        checkMainExported tcg_env+                      ; -- When a module header is specified,+                        -- check that the main module exports a main function.+                        -- (must be after tcRnExports)+                        when explicit_mod_hdr $ checkMainExported tcg_env                       ; -- Compare hi-boot iface (if any) with the real thing                         -- Must be done after processing the exports                         tcg_env <- checkHiBootIface tcg_env boot_info@@ -1795,11 +1797,10 @@       Just main_name ->          do { dflags <- getDynFlags             ; let main_mod = mainModIs dflags-            ; when (ghcLink dflags /= LinkInMemory) $      -- #11647-                checkTc (main_name `elem`+            ; checkTc (main_name `elem`                            concatMap availNames (tcg_exports tcg_env)) $-                   text "The" <+> ppMainFn (nameRdrName main_name) <+>-                   text "is not exported by module" <+> quotes (ppr main_mod) }+                text "The" <+> ppMainFn (nameRdrName main_name) <+>+                text "is not exported by module" <+> quotes (ppr main_mod) }  ppMainFn :: RdrName -> SDoc ppMainFn main_fn

@@ -140,10 +140,10 @@              -> TcRn [y] accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum   where f' acc x = do-          m <- try_m (f acc x)+          m <- attemptM (f acc x)           pure $ case m of-            Right (Just (acc', y)) -> (acc', Just y)-            _                      -> (acc, Nothing)+            Just (Just (acc', y)) -> (acc', Just y)+            _                     -> (acc, Nothing)  type ExportOccMap = OccEnv (Name, IE GhcPs)         -- Tracks what a particular exported OccName@@ -190,7 +190,7 @@         ; let do_it = exports_from_avail real_exports rdr_env imports this_mod         ; (rn_exports, final_avails)             <- if hsc_src == HsigFile-                then do (msgs, mb_r) <- tryTc do_it+                then do (mb_r, msgs) <- tryTc do_it                         case mb_r of                             Just r  -> return r                             Nothing -> addMessages msgs >> failM

@@ -71,7 +71,7 @@   -- * Shared error message stuff: renamer and typechecker   mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,-  try_m, tryTc,+  attemptM, tryTc,   askNoErrs, discardErrs, tryTcDiscardingErrs,   checkNoErrs, whenNoErrs,   ifErrsM, failIfErrsM,@@ -986,130 +986,8 @@        ; (warns, errs) <- readTcRef errs_var        ; writeTcRef errs_var (warns `snocBag` warn, errs) } -try_m :: TcRn r -> TcRn (Either IOEnvFailure r)--- Does tryM, with a debug-trace on failure--- If we do recover from an exception, /insoluble/ constraints--- (only) in 'thing' are are propagated-try_m thing-  = do { (mb_r, lie) <- tryCaptureConstraints thing-       ; emitConstraints lie -       -- Debug trace-       ; case mb_r of-            Left exn -> traceTc "tryTc/recoverM recovering from" $-                        (text (showException exn) $$ ppr lie)-            Right {} -> return ()--       ; return mb_r }- ------------------------recoverM :: TcRn r      -- Recovery action; do this if the main one fails-         -> TcRn r      -- Main action: do this first;-                        --  if it generates errors, propagate them all-         -> TcRn r--- Errors in 'thing' are retained--- If we do recover from an exception, /insoluble/ constraints--- (only) in 'thing' are are propagated-recoverM recover thing-  = do { mb_res <- try_m thing ;-         case mb_res of-           Left _    -> recover-           Right res -> return res }------------------------------ | Drop elements of the input that fail, so the result--- list can be shorter than the argument list-mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]-mapAndRecoverM f = mapMaybeM (fmap rightToMaybe . try_m . f)---- | The accumulator is not updated if the action fails-foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b-foldAndRecoverM _ acc []     = return acc-foldAndRecoverM f acc (x:xs) =-                          do { mb_r <- try_m (f acc x)-                             ; case mb_r of-                                Left _  -> foldAndRecoverM f acc xs-                                Right acc' -> foldAndRecoverM f acc' xs  }---- | Succeeds if applying the argument to all members of the lists succeeds,---   but nevertheless runs it on all arguments, to collect all errors.-mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]-mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)--------------------------tryTc :: TcRn a -> TcRn (Messages, Maybe a)--- (tryTc m) executes m, and returns---      Just r,  if m succeeds (returning r)---      Nothing, if m fails--- It also returns all the errors and warnings accumulated by m--- It always succeeds (never raises an exception)-tryTc thing_inside- = do { errs_var <- newTcRef emptyMessages ;--        res  <- try_m $  -- Be sure to catch exceptions, so that-                         -- we guaranteed to read the messages out-                         -- of that brand-new errs_var!-                setErrsVar errs_var $-                thing_inside ;--        msgs <- readTcRef errs_var ;--        return (msgs, case res of-                        Left _    -> Nothing-                        Right val -> Just val)-        -- The exception is always the IOEnv built-in-        -- in exception; see IOEnv.failM-   }--------------------------discardErrs :: TcRn a -> TcRn a--- (discardErrs m) runs m,---   discarding all error messages and warnings generated by m--- If m fails, discardErrs fails, and vice versa-discardErrs m- = do { errs_var <- newTcRef emptyMessages-      ; setErrsVar errs_var m }--------------------------tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r--- (tryTcDiscardingErrs recover main) tries 'main';---      if 'main' succeeds with no error messages, it's the answer---      otherwise discard everything from 'main', including errors,---          and try 'recover' instead.-tryTcDiscardingErrs recover main-  = do  { (msgs, mb_res) <- tryTc main-        ; dflags <- getDynFlags-        ; case mb_res of-            Just res | not (errorsFound dflags msgs)-              -> -- 'main' succeeed with no error messages-                 do { addMessages msgs  -- msgs might still have warnings-                    ; return res }--            _ -> -- 'main' failed, or produced an error message-                 recover     -- Discard all errors and warnings entirely-        }---------------------------- (askNoErrs m) runs m--- If m fails,---    then (askNoErrs m) fails--- If m succeeds with result r,---    then (askNoErrs m) succeeds with result (r, b),---         where b is True iff m generated no errors--- Regardless of success or failure,---   propagate any errors/warnings generated by m-askNoErrs :: TcRn a -> TcRn (a, Bool)-askNoErrs m-  = do { (msgs, mb_res) <- tryTc m-       ; addMessages msgs  -- Always propagate errors-       ; case mb_res of-           Nothing  -> failM-           Just res -> do { dflags <- getDynFlags-                          ; let errs_found = errorsFound dflags msgs-                          ; return (res, not errs_found) } }------------------------ checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors -- If m fails then (checkNoErrsTc m) fails.@@ -1212,6 +1090,224 @@                            , tcl_ctxt  = tcl_ctxt lcl })               thing_inside ++{- *********************************************************************+*                                                                      *+             Error recovery and exceptions+*                                                                      *+********************************************************************* -}++tcTryM :: TcRn r -> TcRn (Maybe r)+-- The most basic function: catch the exception+--   Nothing => an exception happened+--   Just r  => no exception, result R+-- Errors and constraints are propagated in both cases+-- Never throws an exception+tcTryM thing_inside+  = do { either_res <- tryM thing_inside+       ; return (case either_res of+                    Left _  -> Nothing+                    Right r -> Just r) }+         -- In the Left case the exception is always the IOEnv+         -- built-in in exception; see IOEnv.failM++-----------------------+capture_constraints :: TcM r -> TcM (r, WantedConstraints)+-- capture_constraints simply captures and returns the+--                     constraints generated by thing_inside+-- Precondition: thing_inside must not throw an exception!+-- Reason for precondition: an exception would blow past the place+-- where we read the lie_var, and we'd lose the constraints altogether+capture_constraints thing_inside+  = do { lie_var <- newTcRef emptyWC+       ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $+                thing_inside+       ; lie <- readTcRef lie_var+       ; return (res, lie) }++capture_messages :: TcM r -> TcM (r, Messages)+-- capture_messages simply captures and returns the+--                  errors arnd warnings generated by thing_inside+-- Precondition: thing_inside must not throw an exception!+-- Reason for precondition: an exception would blow past the place+-- where we read the msg_var, and we'd lose the constraints altogether+capture_messages thing_inside+  = do { msg_var <- newTcRef emptyMessages+       ; res     <- setErrsVar msg_var thing_inside+       ; msgs    <- readTcRef msg_var+       ; return (res, msgs) }++-----------------------+-- (askNoErrs m) runs m+-- If m fails,+--    then (askNoErrs m) fails, propagating only+--         insoluble constraints+--+-- If m succeeds with result r,+--    then (askNoErrs m) succeeds with result (r, b),+--         where b is True iff m generated no errors+--+-- Regardless of success or failure,+--   propagate any errors/warnings generated by m+askNoErrs :: TcRn a -> TcRn (a, Bool)+askNoErrs thing_inside+  = do { ((mb_res, lie), msgs) <- capture_messages    $+                                  capture_constraints $+                                  tcTryM thing_inside+       ; addMessages msgs++       ; case mb_res of+           Nothing  -> do { emitConstraints (insolublesOnly lie)+                          ; failM }++           Just res -> do { emitConstraints lie+                          ; dflags <- getDynFlags+                          ; let errs_found = errorsFound dflags msgs+                                          || insolubleWC lie+                          ; return (res, not errs_found) } }++-----------------------+tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)+-- (tryCaptureConstraints_maybe m) runs m,+--   and returns the type constraints it generates+-- It never throws an exception; instead if thing_inside fails,+--   it returns Nothing and the /insoluble/ constraints+-- Error messages are propagated+tryCaptureConstraints thing_inside+  = do { (mb_res, lie) <- capture_constraints $+                          tcTryM thing_inside++       -- See Note [Constraints and errors]+       ; let lie_to_keep = case mb_res of+                             Nothing -> insolublesOnly lie+                             Just {} -> lie++       ; return (mb_res, lie_to_keep) }++captureConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureConstraints m) runs m, and returns the type constraints it generates+-- If thing_inside fails (throwing an exception),+--   then (captureConstraints thing_inside) fails too+--   propagating the insoluble constraints only+-- Error messages are propagated in either case+captureConstraints thing_inside+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside++            -- See Note [Constraints and errors]+            -- If the thing_inside threw an exception, emit the insoluble+            -- constraints only (returned by tryCaptureConstraints)+            -- so that they are not lost+       ; case mb_res of+           Nothing  -> do { emitConstraints lie; failM }+           Just res -> return (res, lie) }++-----------------------+attemptM :: TcRn r -> TcRn (Maybe r)+-- (attemptM thing_inside) runs thing_inside+-- If thing_inside succeeds, returning r,+--   we return (Just r), and propagate all constraints and errors+-- If thing_inside fail, throwing an exception,+--   we return Nothing, propagating insoluble constraints,+--                      and all errors+-- attemptM never throws an exception+attemptM thing_inside+  = do { (mb_r, lie) <- tryCaptureConstraints thing_inside+       ; emitConstraints lie++       -- Debug trace+       ; when (isNothing mb_r) $+         traceTc "attemptM recovering with insoluble constraints" $+                 (ppr lie)++       ; return mb_r }++-----------------------+recoverM :: TcRn r      -- Recovery action; do this if the main one fails+         -> TcRn r      -- Main action: do this first;+                        --  if it generates errors, propagate them all+         -> TcRn r+-- (recoverM recover thing_inside) runs thing_inside+-- If thing_inside fails, propagate its errors and insoluble constraints+--                        and run 'recover'+-- If thing_inside succeeds, propagate all its errors and constraints+--+-- Can fail, if 'recover' fails+recoverM recover thing+  = do { mb_res <- attemptM thing ;+         case mb_res of+           Nothing  -> recover+           Just res -> return res }++-----------------------++-- | Drop elements of the input that fail, so the result+-- list can be shorter than the argument list+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndRecoverM f xs+  = do { mb_rs <- mapM (attemptM . f) xs+       ; return [r | Just r <- mb_rs] }++-- | Apply the function to all elements on the input list+-- If all succeed, return the list of results+-- Othewise fail, propagating all errors+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndReportM f xs+  = do { mb_rs <- mapM (attemptM . f) xs+       ; when (any isNothing mb_rs) failM+       ; return [r | Just r <- mb_rs] }++-- | The accumulator is not updated if the action fails+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b+foldAndRecoverM _ acc []     = return acc+foldAndRecoverM f acc (x:xs) =+                          do { mb_r <- attemptM (f acc x)+                             ; case mb_r of+                                Nothing   -> foldAndRecoverM f acc xs+                                Just acc' -> foldAndRecoverM f acc' xs  }++-----------------------+tryTc :: TcRn a -> TcRn (Maybe a, Messages)+-- (tryTc m) executes m, and returns+--      Just r,  if m succeeds (returning r)+--      Nothing, if m fails+-- It also returns all the errors and warnings accumulated by m+-- It always succeeds (never raises an exception)+tryTc thing_inside+ = capture_messages (attemptM thing_inside)++-----------------------+discardErrs :: TcRn a -> TcRn a+-- (discardErrs m) runs m,+--   discarding all error messages and warnings generated by m+-- If m fails, discardErrs fails, and vice versa+discardErrs m+ = do { errs_var <- newTcRef emptyMessages+      ; setErrsVar errs_var m }++-----------------------+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r+-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';+--      if 'main' succeeds with no error messages, it's the answer+--      otherwise discard everything from 'main', including errors,+--          and try 'recover' instead.+tryTcDiscardingErrs recover thing_inside+  = do { ((mb_res, lie), msgs) <- capture_messages    $+                                  capture_constraints $+                                  tcTryM thing_inside+        ; dflags <- getDynFlags+        ; case mb_res of+            Just res | not (errorsFound dflags msgs)+                     , not (insolubleWC lie)+              -> -- 'main' succeeed with no errors+                 do { addMessages msgs  -- msgs might still have warnings+                    ; emitConstraints lie+                    ; return res }++            _ -> -- 'main' failed, or produced an error message+                 recover     -- Discard all errors and warnings+                             -- and unsolved constraints entirely+        }+ {- ************************************************************************ *                                                                      *@@ -1527,38 +1623,6 @@ discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside -tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)--- (captureConstraints_maybe m) runs m,--- and returns the type constraints it generates--- It never throws an exception; instead if thing_inside fails,---   it returns Left exn and the /insoluble/ constraints-tryCaptureConstraints thing_inside-  = do { lie_var <- newTcRef emptyWC-       ; mb_res <- tryM $-                   updLclEnv (\ env -> env { tcl_lie = lie_var }) $-                   thing_inside-       ; lie <- readTcRef lie_var--       -- See Note [Constraints and errors]-       ; let lie_to_keep = case mb_res of-                             Left {}  -> insolublesOnly lie-                             Right {} -> lie--       ; return (mb_res, lie_to_keep) }--captureConstraints :: TcM a -> TcM (a, WantedConstraints)--- (captureConstraints m) runs m, and returns the type constraints it generates-captureConstraints thing_inside-  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside--            -- See Note [Constraints and errors]-            -- If the thing_inside threw an exception, emit the insoluble-            -- constraints only (returned by tryCaptureConstraints)-            -- so that they are not lost-       ; case mb_res of-           Left _    -> do { emitConstraints lie; failM }-           Right res -> return (res, lie) }- -- | The name says it all. The returned TcLevel is the *inner* TcLevel. pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a) pushLevelAndCaptureConstraints thing_inside@@ -1662,7 +1726,7 @@  The underlying problem is that an exception interrupts the constraint gathering process. Bottom line: if we have an exception, it's best-simply to discard any gathered constraints.  Hence in 'try_m' we+simply to discard any gathered constraints.  Hence in 'attemptM' we capture the constraints in a fresh variable, and only emit them into the surrounding context if we exit normally.  If an exception is raised, simply discard the collected constraints... we have a hard

@@ -168,14 +168,19 @@  tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) tcTySigs hs_sigs-  = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]-    do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs-       ; let ty_sigs  = concat ty_sigs_s+  = checkNoErrs $+    do { -- Fail if any of the signatures is duff+         -- Hence mapAndReportM+         -- See Note [Fail eagerly on bad signatures]+         ty_sigs_s <- mapAndReportM tcTySig hs_sigs++       ; let ty_sigs = concat ty_sigs_s              poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs                         -- The returned [TcId] are the ones for which we have                         -- a complete type signature.                         -- See Note [Complete and partial type signatures]              env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]+        ; return (poly_ids, lookupNameEnv env) }  tcTySig :: LSig GhcRn -> TcM [TcSigInfo]@@ -307,9 +312,15 @@    the code against the signature will give a very similar error    to the ambiguity error. -ToDo: this means we fall over if any type sig-is wrong (eg at the top level of the module),-which is over-conservative+ToDo: this means we fall over if any top-level type signature in the+module is wrong, because we typecheck all the signatures together+(see TcBinds.tcValBinds).  Moreover, because of top-level+captureTopConstraints, only insoluble constraints will be reported.+We typecheck all signatures at the same time because a signature+like   f,g :: blah   might have f and g from different SCCs.++So it's a bit awkward to get better error recovery, and no one+has complained! -}  {- *********************************************************************

@@ -94,10 +94,12 @@        -- constraints, report the latter before propagating the exception        -- Otherwise they will be lost altogether        ; case mb_res of-           Right res -> return (res, lie `andWC` stWC)-           Left {}   -> do { _ <- reportUnsolved lie; failM } }-                -- This call to reportUnsolved is the reason+           Just res -> return (res, lie `andWC` stWC)+           Nothing  -> do { _ <- simplifyTop lie; failM } }+                -- This call to simplifyTop is the reason                 -- this function is here instead of TcRnMonad+                -- We call simplifyTop so that it does defaulting+                -- (esp of runtime-reps) before reporting errors  simplifyTopImplic :: Bag Implication -> TcM () simplifyTopImplic implics

@@ -57,7 +57,6 @@ import HscMain         -- These imports are the reason that TcSplice         -- is very high up the module hierarchy-import FV import RnSplice( traceSplice, SpliceInfo(..)) import RdrName import HscTypes@@ -1474,13 +1473,11 @@   = do { tvs' <- reifyTyVarsToMaybe tvs        ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs        ; lhs' <- reifyTypes lhs_types_only-       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)+       ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc)                                    lhs_types_only lhs'        ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs        ; rhs'  <- reifyType rhs        ; return (TH.TySynEqn tvs' lhs_type rhs') }-  where-    fam_tvs = tyConVisibleTyVars fam_tc  reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc@@ -1708,7 +1705,8 @@ -- | Annotate (with TH.SigT) a type if the first parameter is True -- and if the type contains a free variable. -- This is used to annotate type patterns for poly-kinded tyvars in--- reifying class and type instances. See #8953 and th/T8953.+-- reifying class and type instances.+-- See @Note [Reified instances and explicit kind signatures]@. annotThType :: Bool   -- True <=> annotate             -> TyCoRep.Type -> TH.Type -> TcM TH.Type   -- tiny optimization: if the type is annotated, don't annotate again.@@ -1720,24 +1718,116 @@        ; return (TH.SigT th_ty th_ki) } annotThType _    _ th_ty = return th_ty --- | For every type variable in the input,--- report whether or not the tv is poly-kinded. This is used to eventually--- feed into 'annotThType'.-mkIsPolyTvs :: [TyVar] -> [Bool]-mkIsPolyTvs = map is_poly_tv+-- | For every argument type that a type constructor accepts,+-- report whether or not the argument is poly-kinded. This is used to+-- eventually feed into 'annotThType'.+-- See @Note [Reified instances and explicit kind signatures]@.+tyConArgsPolyKinded :: TyCon -> [Bool]+tyConArgsPolyKinded tc =+     map (is_poly_ty . tyVarKind)      tc_vis_tvs+     -- See "Wrinkle: Oversaturated data family instances" in+     -- @Note [Reified instances and explicit kind signatures]@+  ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle+  ++ repeat True                                             -- (2) in Wrinkle   where-    is_poly_tv tv = not $+    is_poly_ty :: Type -> Bool+    is_poly_ty ty = not $                     isEmptyVarSet $                     filterVarSet isTyVar $-                    tyCoVarsOfType $-                    tyVarKind tv+                    tyCoVarsOfType ty +    tc_vis_tvs :: [TyVar]+    tc_vis_tvs = tyConVisibleTyVars tc++    tc_res_kind_vis_bndrs :: [TyCoBinder]+    tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc++{-+Note [Reified instances and explicit kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Reified class instances and type family instances often include extra kind+information to disambiguate instances. Here is one such example that+illustrates this (#8953):++    type family Poly (a :: k) :: Type+    type instance Poly (x :: Bool)    = Int+    type instance Poly (x :: Maybe k) = Double++If you're not careful, reifying these instances might yield this:++    type instance Poly x = Int+    type instance Poly x = Double++To avoid this, we go through some care to annotate things with extra kind+information. Some functions which accomplish this feat include:++* annotThType: This annotates a type with a kind signature if the type contains+  a free variable.+* tyConArgsPolyKinded: This checks every argument that a type constructor can+  accept and reports if the type of the argument is poly-kinded. This+  information is ultimately fed into annotThType.++-----+-- Wrinkle: Oversaturated data family instances+-----++What constitutes an argument to a type constructor in the definition of+tyConArgsPolyKinded? For most type constructors, it's simply the visible+type variable binders (i.e., tyConVisibleTyVars). There is one corner case+we must keep in mind, however: data family instances can appear oversaturated+(#17296). For instance:++    data family   Foo :: Type -> Type+    data instance Foo x++    data family Bar :: k+    data family Bar x++For these sorts of data family instances, tyConVisibleTyVars isn't enough,+as they won't give you the kinds of the oversaturated arguments. We must+also consult:++1. The kinds of the arguments in the result kind (i.e., the tyConResKind).+   This will tell us, e.g., the kind of `x` in `Foo x` above.+2. If we go beyond the number of arguments in the result kind (like the+   `x` in `Bar x`), then we conservatively assume that the argument's+   kind is poly-kinded.++-----+-- Wrinkle: data family instances with return kinds+-----++Another squirrelly corner case is this:++    data family Foo (a :: k)+    data instance Foo :: Bool -> Type+    data instance Foo :: Char -> Type++If you're not careful, reifying these instances might yield this:++    data instance Foo+    data instance Foo++We can fix this ambiguity by reifying the instances' explicit return kinds. We+should only do this if necessary (see+Note [When does a tycon application need an explicit kind signature?] in Type),+but more importantly, we *only* do this if either of the following are true:++1. The data family instance has no constructors.+2. The data family instance is declared with GADT syntax.++If neither of these are true, then reifying the return kind would yield+something like this:++    data instance (Bar a :: Type) = MkBar a++Which is not valid syntax.+-}+ ------------------------------ reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] reifyClassInstances cls insts-  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts-  where-    tvs = tyConVisibleTyVars (classTyCon cls)+  = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts  reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded                               -- includes only *visible* tvs@@ -1763,9 +1853,7 @@ ------------------------------ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] reifyFamilyInstances fam_tc fam_insts-  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts-  where-    fam_tvs = tyConVisibleTyVars fam_tc+  = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts  reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded                               -- includes only *visible* tvs@@ -1802,10 +1890,19 @@            ; th_tys <- reifyTypes types_only            ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys            ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys+           ; mb_sig <-+               -- See "Wrinkle: data family instances with return kinds" in+               -- Note [Reified instances and explicit kind signatures]+               if (null cons || isGadtSyntaxTyCon rep_tc)+                     && tyConAppNeedsKindSig False fam_tc (length ee_lhs)+               then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs)+                       ; th_full_kind <- reifyKind full_kind+                       ; pure $ Just th_full_kind }+               else pure Nothing            ; return $                if isNewTyCon rep_tc-               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []-               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []+               then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) []+               else TH.DataInstD    [] th_tvs lhs_type mb_sig       cons  []            }  ------------------------------@@ -1895,109 +1992,12 @@ reifyTyVarsToMaybe []  = pure Nothing reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys -{--Note [Kind annotations on TyConApps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.-For example:--   type family F a :: k-   type instance F Int  = (Proxy :: * -> *)-   type instance F Bool = (Proxy :: (* -> *) -> *)--It's hard to figure out where these annotations should appear, so we do this:-Suppose we have a tycon application (T ty1 ... tyn). Assuming that T is not-oversatured (more on this later), we can assume T's declaration is of the form-T (tvb1 :: s1) ... (tvbn :: sn) :: p. If any kind variable that-is free in p is not free in an injective position in tvb1 ... tvbn,-then we put on a kind annotation, since we would not otherwise be able to infer-the kind of the whole tycon application.--The injective positions in a tyvar binder are the injective positions in the-kind of its tyvar, provided the tyvar binder is either:--* Anonymous. For example, in the promoted data constructor '(:):--    '(:) :: forall a. a -> [a] -> [a]--  The second and third tyvar binders (of kinds `a` and `[a]`) are both-  anonymous, so if we had '(:) 'True '[], then the inferred kinds of 'True and-  '[] would contribute to the inferred kind of '(:) 'True '[].-* Has required visibility. For example, in the type family:--    type family Wurble k (a :: k) :: k-    Wurble :: forall k -> k -> k--  The first tyvar binder (of kind `forall k`) has required visibility, so if-  we had Wurble (Maybe a) Nothing, then the inferred kind of Maybe a would-  contribute to the inferred kind of Wurble (Maybe a) Nothing.--An injective position in a type is one that does not occur as an argument to-a non-injective type constructor (e.g., non-injective type families). See-injectiveVarsOfType.--How can be sure that this is correct? That is, how can we be sure that in the-event that we leave off a kind annotation, that one could infer the kind of the-tycon application from its arguments? It's essentially a proof by induction: if-we can infer the kinds of every subtree of a type, then the whole tycon-application will have an inferrable kind--unless, of course, the remainder of-the tycon application's kind has uninstantiated kind variables.--An earlier implementation of this algorithm only checked if p contained any-free variables. But this was unsatisfactory, since a datatype like this:--  data Foo = Foo (Proxy '[False, True])--Would be reified like this:--  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool])-                                     :: [Bool]) :: [Bool]))--Which has a rather excessive amount of kind annotations. With the current-algorithm, we instead reify Foo to this:--  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool]))))--Since in the case of '[], the kind p is [a], and there are no arguments in the-kind of '[]. On the other hand, in the case of '(:) True '[], the kind p is-(forall a. [a]), but a occurs free in the first and second arguments of the-full kind of '(:), which is (forall a. a -> [a] -> [a]). (See Trac #14060.)--What happens if T is oversaturated? That is, if T's kind has fewer than n-arguments, in the case that the concrete application instantiates a result-kind variable with an arrow kind? If we run out of arguments, we do not attach-a kind annotation. This should be a rare case, indeed. Here is an example:--   data T1 :: k1 -> k2 -> *-   data T2 :: k1 -> k2 -> *--   type family G (a :: k) :: k-   type instance G T1 = T2--   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above--Here G's kind is (forall k. k -> k), and the desugared RHS of that last-instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to-the algorithm above, there are 3 arguments to G so we should peel off 3-arguments in G's kind. But G's kind has only two arguments. This is the-rare special case, and we choose not to annotate the application of G with-a kind signature. After all, we needn't do this, since that instance would-be reified as:--   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool--So the kind of G isn't ambiguous anymore due to the explicit kind annotation-on its argument. See #8953 and test th/T8953.--}- reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type reify_tc_app tc tys   = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)        ; maybe_sig_t (mkThAppTs r_tc tys') }   where     arity       = tyConArity tc-    tc_binders  = tyConBinders tc-    tc_res_kind = tyConResKind tc      r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)          | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)@@ -2018,27 +2018,19 @@          | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)          | otherwise                      = TH.ConT (reifyName tc) -    -- See Note [Kind annotations on TyConApps]+    -- See Note [When does a tycon application need an explicit kind+    -- signature?] in TyCoRep     maybe_sig_t th_type-      | needs_kind_sig+      | tyConAppNeedsKindSig+          False -- We don't reify types using visible kind applications, so+                -- don't count specified binders as contributing towards+                -- injective positions in the kind of the tycon.+          tc (length tys)       = do { let full_kind = tcTypeKind (mkTyConApp tc tys)            ; th_full_kind <- reifyKind full_kind            ; return (TH.SigT th_type th_full_kind) }       | otherwise       = return th_type--    needs_kind_sig-      | GT <- compareLength tys tc_binders-      = False-      | otherwise-      = let (dropped_binders, remaining_binders)-              = splitAtList  tys tc_binders-            result_kind  = mkTyConKind remaining_binders tc_res_kind-            result_vars  = tyCoVarsOfType result_kind-            dropped_vars = fvVarSet $-                           mapUnionFV injectiveVarsOfBinder dropped_binders--        in not (subVarSet result_vars dropped_vars)  ------------------------------ reifyName :: NamedThing n => n -> TH.Name

@@ -1180,8 +1180,15 @@   | otherwise   = do { ev_binds <- newNoTcEvBinds        ; implic   <- newImplication+       ; let status | insolubleWC wanted = IC_Insoluble+                    | otherwise          = IC_Unsolved+             -- If the inner constraints are insoluble,+             -- we should mark the outer one similarly,+             -- so that insolubleWC works on the outer one+        ; emitImplication $-         implic { ic_tclvl     = tclvl+         implic { ic_status    = status+                , ic_tclvl     = tclvl                 , ic_skols     = skol_tvs                 , ic_no_eqs    = True                 , ic_telescope = m_telescope

@@ -1360,7 +1360,8 @@   = do { dflags   <- getDynFlags        ; is_boot  <- tcIsHsBootOrSig        ; is_sig   <- tcIsHsig-       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args+       ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args+       ; checkValidTypePats (classTyCon clas) cls_args        }  {-@@ -1388,10 +1389,10 @@  -} -check_valid_inst_head :: DynFlags -> Bool -> Bool-                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()+check_special_inst_head :: DynFlags -> Bool -> Bool+                        -> UserTypeCtxt -> Class -> [Type] -> TcM () -- Wow!  There are a surprising number of ad-hoc special cases here.-check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args+check_special_inst_head dflags is_boot is_sig ctxt clas cls_args    -- If not in an hs-boot file, abstract classes cannot have instances   | isAbstractClass clas@@ -1441,7 +1442,7 @@   = failWithTc (instTypeErr clas cls_args msg)    | otherwise-  = checkValidTypePats (classTyCon clas) cls_args+  = pure ()   where     clas_nm = getName clas     ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args

@@ -90,7 +90,7 @@         tyCoFVsOfCo, tyCoFVsOfCos,         tyCoVarsOfCoList, tyCoVarsOfProv,         almostDevoidCoVarOfCo,-        injectiveVarsOfBinder, injectiveVarsOfType,+        injectiveVarsOfType, tyConAppNeedsKindSig,          noFreeVarsOfType, noFreeVarsOfCo, @@ -2100,20 +2100,21 @@  ------------- Injective free vars ----------------- --- | Returns the free variables of a 'TyConBinder' that are in injective--- positions. (See @Note [Kind annotations on TyConApps]@ in "TcSplice" for an--- explanation of what an injective position is.)-injectiveVarsOfBinder :: TyConBinder -> FV-injectiveVarsOfBinder (Bndr tv vis) =-  case vis of-    AnonTCB           -> injectiveVarsOfType (varType tv)-    NamedTCB Required -> unitFV tv `unionFV`-                         injectiveVarsOfType (varType tv)-    NamedTCB _        -> emptyFV- -- | Returns the free variables of a 'Type' that are in injective positions.--- (See @Note [Kind annotations on TyConApps]@ in "TcSplice" for an explanation--- of what an injective position is.)+-- For example, if @F@ is a non-injective type family, then:+--+-- @+-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c}+-- @+--+-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@.+-- More formally, if+-- @a@ is in @'injectiveVarsOfType' ty@+-- and  @S1(ty) ~ S2(ty)@,+-- then @S1(a)  ~ S2(a)@,+-- where @S1@ and @S2@ are arbitrary substitutions.+--+-- See @Note [When does a tycon application need an explicit kind signature?]@. injectiveVarsOfType :: Type -> FV injectiveVarsOfType = go   where@@ -2129,11 +2130,283 @@                          filterByList (inj ++ repeat True) tys                          -- Oversaturated arguments to a tycon are                          -- always injective, hence the repeat True-    go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go (binderType tvb)-                                             `unionFV` go ty+    go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty     go LitTy{}           = emptyFV     go (CastTy ty _)     = go ty     go CoercionTy{}      = emptyFV++-- | Does a 'TyCon' (that is applied to some number of arguments) need to be+-- ascribed with an explicit kind signature to resolve ambiguity if rendered as+-- a source-syntax type?+-- (See @Note [When does a tycon application need an explicit kind signature?]@+-- for a full explanation of what this function checks for.)++-- Morally, this function ought to belong in TyCon.hs, not TyCoRep.hs, but+-- accomplishing this requires a fair deal of futzing aruond with .hs-boot+-- files.+tyConAppNeedsKindSig+  :: Bool  -- ^ Should specified binders count towards injective positions in+           --   the kind of the TyCon?+  -> TyCon+  -> Int   -- ^ The number of args the 'TyCon' is applied to.+  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the+           --   number of arguments)+tyConAppNeedsKindSig spec_inj_pos tc n_args+  | LT <- listLengthCmp tc_binders n_args+  = False+  | otherwise+  = let (dropped_binders, remaining_binders)+          = splitAt n_args tc_binders+        result_kind  = mkTyConKind remaining_binders tc_res_kind+        result_vars  = tyCoVarsOfType result_kind+        dropped_vars = fvVarSet $+                       mapUnionFV (injective_vars_of_binder spec_inj_pos)+                                  dropped_binders++    in not (subVarSet result_vars dropped_vars)+  where+    tc_binders  = tyConBinders tc+    tc_res_kind = tyConResKind tc++    -- Returns the variables that would be fixed by knowing a TyConBinder. See+    -- Note [When does a tycon application need an explicit kind signature?]+    -- for a more detailed explanation of what this function does.+    injective_vars_of_binder+      :: Bool -- Should specified binders count towards injective positions?+              -- (If you're using visible kind applications, then you want True+              -- here.)+      -> TyConBinder -> FV+    injective_vars_of_binder spec_inj_pos (Bndr tv vis) =+      case vis of+        AnonTCB -> injectiveVarsOfType (varType tv)+        NamedTCB argf+          |     (argf == Required)+             || (spec_inj_pos && (argf == Specified))+          -> unitFV tv `unionFV` injectiveVarsOfType (varType tv)+          |  otherwise+          -> emptyFV++{-+Note [When does a tycon application need an explicit kind signature?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a couple of places in GHC where we convert Core Types into forms that+more closely resemble user-written syntax. These include:++1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app)+2. Converting Types to LHsTypes (in HsUtils.typeToLHsType, or in Haddock)++This conversion presents a challenge: how do we ensure that the resulting type+has enough kind information so as not to be ambiguous? To better motivate this+question, consider the following Core type:++  -- Foo :: Type -> Type+  type Foo = Proxy Type++There is nothing ambiguous about the RHS of Foo in Core. But if we were to,+say, reify it into a TH Type, then it's tempting to just drop the invisible+Type argument and simply return `Proxy`. But now we've lost crucial kind+information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`+or `Proxy Int` or something else! We've inadvertently introduced ambiguity.++Unlike in other situations in GHC, we can't just turn on+-fprint-explicit-kinds, as we need to produce something which has the same+structure as a source-syntax type. Moreover, we can't rely on visible kind+application, since the first kind argument to Proxy is inferred, not specified.+Our solution is to annotate certain tycons with their kinds whenever they+appear in applied form in order to resolve the ambiguity. For instance, we+would reify the RHS of Foo like so:++  type Foo = (Proxy :: Type -> Type)++We need to devise an algorithm that determines precisely which tycons need+these explicit kind signatures. We certainly don't want to annotate _every_+tycon with a kind signature, or else we might end up with horribly bloated+types like the following:++  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)++We only want to annotate tycons that absolutely require kind signatures in+order to resolve some sort of ambiguity, and nothing more.++Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type+require a kind signature? It might require it when we need to fill in any of+T's omitted arguments. By "omitted argument", we mean one that is dropped when+reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and+specified arguments (e.g., TH reification in TcSplice), and sometimes the+omitted arguments are only the inferred ones (e.g., in HsUtils.typeToLHsType,+which reifies specified arguments through visible kind application).+Regardless, the key idea is that _some_ arguments are going to be omitted after+reification, and the only mechanism we have at our disposal for filling them in+is through explicit kind signatures.++What do we mean by "fill in"? Let's consider this small example:++  T :: forall {k}. Type -> (k -> Type) -> k++Moreover, we have this application of T:++  T @{j} Int aty++When we reify this type, we omit the inferred argument @{j}. Is it fixed by the+other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then+we'll generate an equality constraint (kappa -> Type) and, assuming we can+solve it, that will fix `kappa`. (Here, `kappa` is the unification variable+that we instantiate `k` with.)++Therefore, for any application of a tycon T to some arguments, the Question We+Must Answer is:++* Given the first n arguments of T, do the kinds of the non-omitted arguments+  fill in the omitted arguments?++(This is still a bit hand-wavey, but we'll refine this question incrementally+as we explain more of the machinery underlying this process.)++Answering this question is precisely the role that the `injectiveVarsOfType`+and `injective_vars_of_binder` functions exist to serve. If an omitted argument+`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing+`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a+bit.)++More formally, if+`a` is in `injectiveVarsOfType ty`+and  S1(ty) ~ S2(ty),+then S1(a)  ~ S2(a),+where S1 and S2 are arbitrary substitutions.++For example, is `F` is a non-injective type family, then++  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}++Now that we know what this function does, here is a second attempt at the+Question We Must Answer:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. Do the injective+  variables of these binders fill in the remainder of T's kind?++Alright, we're getting closer. Next, we need to clarify what the injective+variables of a tycon binder are. This the role that the+`injective_vars_of_binder` function serves. Here is what this function does for+each form of tycon binder:++* Anonymous binders are injective positions. For example, in the promoted data+  constructor '(:):++    '(:) :: forall a. a -> [a] -> [a]++  The second and third tyvar binders (of kinds `a` and `[a]`) are both+  anonymous, so if we had '(:) 'True '[], then the kinds of 'True and+  '[] would contribute to the kind of '(:) 'True '[]. Therefore,+  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.+  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)+* Named binders:+  - Inferred binders are never injective positions. For example, in this data+    type:++      data Proxy a+      Proxy :: forall {k}. k -> Type++    If we had Proxy 'True, then the kind of 'True would not contribute to the+    kind of Proxy 'True. Therefore,+    injective_vars_of_binder(forall {k}. ...) = {}.+  - Required binders are injective positions. For example, in this data type:++      data Wurble k (a :: k) :: k+      Wurble :: forall k -> k -> k++  The first tyvar binder (of kind `forall k`) has required visibility, so if+  we had Wurble (Maybe a) Nothing, then the kind of Maybe a would+  contribute to the kind of Wurble (Maybe a) Nothing. Hence,+  injective_vars_of_binder(forall a -> ...) = {a}.+  - Specified binders /might/ be injective positions, depending on how you+    approach things. Continuing the '(:) example:++      '(:) :: forall a. a -> [a] -> [a]++    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind+    of '(:) 'True '[], since it's not explicitly instantiated by the user. But+    if visible kind application is enabled, then this is possible, since the+    user can write '(:) @Bool 'True '[]. (In that case,+    injective_vars_of_binder(forall a. ...) = {a}.)++    There are some situations where using visible kind application is appropriate+    (e.g., HsUtils.typeToLHsType) and others where it is not (e.g., TH+    reification), so the `injective_vars_of_binder` function is parametrized by+    a Bool which decides if specified binders should be counted towards+    injective positions or not.++Now that we've defined injective_vars_of_binder, we can refine the Question We+Must Answer once more:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the remainder of T's kind?++If the answer to this question is "no", then (T ty_1 ... ty_n) needs an+explicit kind signature, since T's kind has kind variables leftover that+aren't fixed by the non-omitted arguments.++One last sticking point: what does "the remainder of T's kind" mean? You might+be tempted to think that it corresponds to all of the arguments in the kind of+T that would normally be instantiated by omitted arguments. But this isn't+quite right, strictly speaking. Consider the following (silly) example:++  S :: forall {k}. Type -> Type++And suppose we have this application of S:++  S Int Bool++The Int argument would be omitted, and+injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which+might suggest that (S Bool) needs an explicit kind signature. But+(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature+only affects the /result/ of the application, not all of the individual+arguments. So adding a kind signature here won't make a difference. Therefore,+the fourth (and final) iteration of the Question We Must Answer is:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the kind of (T ty_1 ... ty_n)?++Phew, that was a lot of work!++How can be sure that this is correct? That is, how can we be sure that in the+event that we leave off a kind annotation, that one could infer the kind of the+tycon application from its arguments? It's essentially a proof by induction: if+we can infer the kinds of every subtree of a type, then the whole tycon+application will have an inferrable kind--unless, of course, the remainder of+the tycon application's kind has uninstantiated kind variables.++What happens if T is oversaturated? That is, if T's kind has fewer than n+arguments, in the case that the concrete application instantiates a result+kind variable with an arrow kind? If we run out of arguments, we do not attach+a kind annotation. This should be a rare case, indeed. Here is an example:++   data T1 :: k1 -> k2 -> *+   data T2 :: k1 -> k2 -> *++   type family G (a :: k) :: k+   type instance G T1 = T2++   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above++Here G's kind is (forall k. k -> k), and the desugared RHS of that last+instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to+the algorithm above, there are 3 arguments to G so we should peel off 3+arguments in G's kind. But G's kind has only two arguments. This is the+rare special case, and we choose not to annotate the application of G with+a kind signature. After all, we needn't do this, since that instance would+be reified as:++   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool++So the kind of G isn't ambiguous anymore due to the explicit kind annotation+on its argument. See #8953 and test th/T8953.+-}  ------------- No free vars ----------------- 

@@ -1686,7 +1686,6 @@ tyCoBinderVar_maybe _          = Nothing  tyCoBinderType :: TyCoBinder -> Type--- Barely used tyCoBinderType (Named tvb) = binderType tvb tyCoBinderType (Anon ty)   = ty