diff --git a/autogen/Config.hs b/autogen/Config.hs --- a/autogen/Config.hs +++ b/autogen/Config.hs @@ -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 diff --git a/cmm/MkGraph.hs b/cmm/MkGraph.hs --- a/cmm/MkGraph.hs +++ b/cmm/MkGraph.hs @@ -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) diff --git a/codeGen/StgCmmClosure.hs b/codeGen/StgCmmClosure.hs --- a/codeGen/StgCmmClosure.hs +++ b/codeGen/StgCmmClosure.hs @@ -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 diff --git a/codeGen/StgCmmExpr.hs b/codeGen/StgCmmExpr.hs --- a/codeGen/StgCmmExpr.hs +++ b/codeGen/StgCmmExpr.hs @@ -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] diff --git a/coreSyn/CorePrep.hs b/coreSyn/CorePrep.hs --- a/coreSyn/CorePrep.hs +++ b/coreSyn/CorePrep.hs @@ -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 diff --git a/coreSyn/CoreUtils.hs b/coreSyn/CoreUtils.hs --- a/coreSyn/CoreUtils.hs +++ b/coreSyn/CoreUtils.hs @@ -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)) diff --git a/deSugar/Check.hs b/deSugar/Check.hs --- a/deSugar/Check.hs +++ b/deSugar/Check.hs @@ -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, diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -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 diff --git a/ghci/RtClosureInspect.hs b/ghci/RtClosureInspect.hs --- a/ghci/RtClosureInspect.hs +++ b/ghci/RtClosureInspect.hs @@ -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 diff --git a/hsSyn/HsUtils.hs b/hsSyn/HsUtils.hs --- a/hsSyn/HsUtils.hs +++ b/hsSyn/HsUtils.hs @@ -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. -} {- ********************************************************************* diff --git a/iface/IfaceSyn.hs b/iface/IfaceSyn.hs --- a/iface/IfaceSyn.hs +++ b/iface/IfaceSyn.hs @@ -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 diff --git a/iface/TcIface.hs b/iface/TcIface.hs --- a/iface/TcIface.hs +++ b/iface/TcIface.hs @@ -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 diff --git a/llvmGen/LlvmCodeGen.hs b/llvmGen/LlvmCodeGen.hs --- a/llvmGen/LlvmCodeGen.hs +++ b/llvmGen/LlvmCodeGen.hs @@ -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 diff --git a/llvmGen/LlvmCodeGen/Base.hs b/llvmGen/LlvmCodeGen/Base.hs --- a/llvmGen/LlvmCodeGen/Base.hs +++ b/llvmGen/LlvmCodeGen/Base.hs @@ -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 diff --git a/main/DriverPipeline.hs b/main/DriverPipeline.hs --- a/main/DriverPipeline.hs +++ b/main/DriverPipeline.hs @@ -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" diff --git a/main/GHC.hs b/main/GHC.hs --- a/main/GHC.hs +++ b/main/GHC.hs @@ -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 diff --git a/main/SysTools/Process.hs b/main/SysTools/Process.hs --- a/main/SysTools/Process.hs +++ b/main/SysTools/Process.hs @@ -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 diff --git a/main/SysTools/Tasks.hs b/main/SysTools/Tasks.hs --- a/main/SysTools/Tasks.hs +++ b/main/SysTools/Tasks.hs @@ -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 () diff --git a/nativeGen/AsmCodeGen.hs b/nativeGen/AsmCodeGen.hs --- a/nativeGen/AsmCodeGen.hs +++ b/nativeGen/AsmCodeGen.hs @@ -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 diff --git a/nativeGen/BlockLayout.hs b/nativeGen/BlockLayout.hs --- a/nativeGen/BlockLayout.hs +++ b/nativeGen/BlockLayout.hs @@ -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 diff --git a/nativeGen/CFG.hs b/nativeGen/CFG.hs --- a/nativeGen/CFG.hs +++ b/nativeGen/CFG.hs @@ -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 ) +-- 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 + diff --git a/nativeGen/Dwarf/Types.hs b/nativeGen/Dwarf/Types.hs --- a/nativeGen/Dwarf/Types.hs +++ b/nativeGen/Dwarf/Types.hs @@ -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) diff --git a/nativeGen/NCGMonad.hs b/nativeGen/NCGMonad.hs --- a/nativeGen/NCGMonad.hs +++ b/nativeGen/NCGMonad.hs @@ -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; ` -- 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) diff --git a/nativeGen/RegAlloc/Liveness.hs b/nativeGen/RegAlloc/Liveness.hs --- a/nativeGen/RegAlloc/Liveness.hs +++ b/nativeGen/RegAlloc/Liveness.hs @@ -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 ] diff --git a/nativeGen/X86/CodeGen.hs b/nativeGen/X86/CodeGen.hs --- a/nativeGen/X86/CodeGen.hs +++ b/nativeGen/X86/CodeGen.hs @@ -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: + + _B1: + ... + cmpxchgq ... + jne _B1 + + + _B2: + ... + cmpxchgq ... + jne _B2 + + 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: + + _B1: + ... + cmpxchgq ... + jne _B1 + jmp _B1' + _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 diff --git a/nativeGen/X86/Instr.hs b/nativeGen/X86/Instr.hs --- a/nativeGen/X86/Instr.hs +++ b/nativeGen/X86/Instr.hs @@ -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 diff --git a/parser/Parser.hs b/parser/Parser.hs --- a/parser/Parser.hs +++ b/parser/Parser.hs @@ -32,6 +32,7 @@ import Data.Char import Control.Monad ( mplus ) import Control.Applicative ((<$)) +import qualified Prelude -- compiler/hsSyn import HsSyn diff --git a/simplCore/OccurAnal.hs b/simplCore/OccurAnal.hs --- a/simplCore/OccurAnal.hs +++ b/simplCore/OccurAnal.hs @@ -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] diff --git a/typecheck/TcBackpack.hs b/typecheck/TcBackpack.hs --- a/typecheck/TcBackpack.hs +++ b/typecheck/TcBackpack.hs @@ -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 diff --git a/typecheck/TcBinds.hs b/typecheck/TcBinds.hs --- a/typecheck/TcBinds.hs +++ b/typecheck/TcBinds.hs @@ -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 :: + -- 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 diff --git a/typecheck/TcRnDriver.hs b/typecheck/TcRnDriver.hs --- a/typecheck/TcRnDriver.hs +++ b/typecheck/TcRnDriver.hs @@ -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 diff --git a/typecheck/TcRnExports.hs b/typecheck/TcRnExports.hs --- a/typecheck/TcRnExports.hs +++ b/typecheck/TcRnExports.hs @@ -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 diff --git a/typecheck/TcRnMonad.hs b/typecheck/TcRnMonad.hs --- a/typecheck/TcRnMonad.hs +++ b/typecheck/TcRnMonad.hs @@ -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 diff --git a/typecheck/TcSigs.hs b/typecheck/TcSigs.hs --- a/typecheck/TcSigs.hs +++ b/typecheck/TcSigs.hs @@ -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! -} {- ********************************************************************* diff --git a/typecheck/TcSimplify.hs b/typecheck/TcSimplify.hs --- a/typecheck/TcSimplify.hs +++ b/typecheck/TcSimplify.hs @@ -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 diff --git a/typecheck/TcSplice.hs b/typecheck/TcSplice.hs --- a/typecheck/TcSplice.hs +++ b/typecheck/TcSplice.hs @@ -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 diff --git a/typecheck/TcUnify.hs b/typecheck/TcUnify.hs --- a/typecheck/TcUnify.hs +++ b/typecheck/TcUnify.hs @@ -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 diff --git a/typecheck/TcValidity.hs b/typecheck/TcValidity.hs --- a/typecheck/TcValidity.hs +++ b/typecheck/TcValidity.hs @@ -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 diff --git a/types/TyCoRep.hs b/types/TyCoRep.hs --- a/types/TyCoRep.hs +++ b/types/TyCoRep.hs @@ -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 ----------------- diff --git a/types/Type.hs b/types/Type.hs --- a/types/Type.hs +++ b/types/Type.hs @@ -1686,7 +1686,6 @@ tyCoBinderVar_maybe _ = Nothing tyCoBinderType :: TyCoBinder -> Type --- Barely used tyCoBinderType (Named tvb) = binderType tvb tyCoBinderType (Anon ty) = ty